Text stippling is not available under openGL.

Line ends and line joins are not fully implemented under openGL.
The default behavior if to draw round ends and joins.

Line dashes are not really usable in openGL. Some cases work ok,
like aligned rectangles and other not, like curves and arcs.

Tiling/stippling begin on the item or item bounding box edge
rather than on the border edge so that the tile/stipple is
partially masked by the border.

Item tiling is not available for Windows GDI.

Maps are not rendered filled in openGL. The code of maps still
lags behind.

Copyright (c) 2005, Centre d'études de la Navigation Aérienne, Patrick Lecoanet
All rights reserved.

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

		  GNU LESSER GENERAL PUBLIC LICENSE
		       Version 2.1, February 1999

 Copyright (C) 1991, 1999 Free Software Foundation, Inc.
     51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

[This is the first released version of the Lesser GPL.  It also counts
 as the successor of the GNU Library Public License, version 2, hence
 the version number 2.1.]

			    Preamble

  The licenses for most software are designed to take away your
freedom to share and change it.  By contrast, the GNU General Public
Licenses are intended to guarantee your freedom to share and change
free software--to make sure the software is free for all its users.

  This license, the Lesser General Public License, applies to some
specially designated software packages--typically libraries--of the
Free Software Foundation and other authors who decide to use it.  You
can use it too, but we suggest you first think carefully about whether
this license or the ordinary General Public License is the better
strategy to use in any particular case, based on the explanations below.

  When we speak of free software, we are referring to freedom of use,
not price.  Our General Public Licenses are designed to make sure that
you have the freedom to distribute copies of free software (and charge
for this service if you wish); that you receive source code or can get
it if you want it; that you can change the software and use pieces of
it in new free programs; and that you are informed that you can do
these things.

  To protect your rights, we need to make restrictions that forbid
distributors to deny you these rights or to ask you to surrender these
rights.  These restrictions translate to certain responsibilities for
you if you distribute copies of the library or if you modify it.

  For example, if you distribute copies of the library, whether gratis
or for a fee, you must give the recipients all the rights that we gave
you.  You must make sure that they, too, receive or can get the source
code.  If you link other code with the library, you must provide
complete object files to the recipients, so that they can relink them
with the library after making changes to the library and recompiling
it.  And you must show them these terms so they know their rights.

  We protect your rights with a two-step method: (1) we copyright the
library, and (2) we offer you this license, which gives you legal
permission to copy, distribute and/or modify the library.

  To protect each distributor, we want to make it very clear that
there is no warranty for the free library.  Also, if the library is
modified by someone else and passed on, the recipients should know
that what they have is not the original version, so that the original
author's reputation will not be affected by problems that might be
introduced by others.

  Finally, software patents pose a constant threat to the existence of
any free program.  We wish to make sure that a company cannot
effectively restrict the users of a free program by obtaining a
restrictive license from a patent holder.  Therefore, we insist that
any patent license obtained for a version of the library must be
consistent with the full freedom of use specified in this license.

  Most GNU software, including some libraries, is covered by the
ordinary GNU General Public License.  This license, the GNU Lesser
General Public License, applies to certain designated libraries, and
is quite different from the ordinary General Public License.  We use
this license for certain libraries in order to permit linking those
libraries into non-free programs.

  When a program is linked with a library, whether statically or using
a shared library, the combination of the two is legally speaking a
combined work, a derivative of the original library.  The ordinary
General Public License therefore permits such linking only if the
entire combination fits its criteria of freedom.  The Lesser General
Public License permits more lax criteria for linking other code with
the library.

  We call this license the "Lesser" General Public License because it
does Less to protect the user's freedom than the ordinary General
Public License.  It also provides other free software developers Less
of an advantage over competing non-free programs.  These disadvantages
are the reason we use the ordinary General Public License for many
libraries.  However, the Lesser license provides advantages in certain
special circumstances.

  For example, on rare occasions, there may be a special need to
encourage the widest possible use of a certain library, so that it becomes
a de-facto standard.  To achieve this, non-free programs must be
allowed to use the library.  A more frequent case is that a free
library does the same job as widely used non-free libraries.  In this
case, there is little to gain by limiting the free library to free
software only, so we use the Lesser General Public License.

  In other cases, permission to use a particular library in non-free
programs enables a greater number of people to use a large body of
free software.  For example, permission to use the GNU C Library in
non-free programs enables many more people to use the whole GNU
operating system, as well as its variant, the GNU/Linux operating
system.

  Although the Lesser General Public License is Less protective of the
users' freedom, it does ensure that the user of a program that is
linked with the Library has the freedom and the wherewithal to run
that program using a modified version of the Library.

  The precise terms and conditions for copying, distribution and
modification follow.  Pay close attention to the difference between a
"work based on the library" and a "work that uses the library".  The
former contains code derived from the library, whereas the latter must
be combined with the library in order to run.

		  GNU LESSER GENERAL PUBLIC LICENSE
   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

  0. This License Agreement applies to any software library or other
program which contains a notice placed by the copyright holder or
other authorized party saying it may be distributed under the terms of
this Lesser General Public License (also called "this License").
Each licensee is addressed as "you".

  A "library" means a collection of software functions and/or data
prepared so as to be conveniently linked with application programs
(which use some of those functions and data) to form executables.

  The "Library", below, refers to any such software library or work
which has been distributed under these terms.  A "work based on the
Library" means either the Library or any derivative work under
copyright law: that is to say, a work containing the Library or a
portion of it, either verbatim or with modifications and/or translated
straightforwardly into another language.  (Hereinafter, translation is
included without limitation in the term "modification".)

  "Source code" for a work means the preferred form of the work for
making modifications to it.  For a library, complete source code means
all the source code for all modules it contains, plus any associated
interface definition files, plus the scripts used to control compilation
and installation of the library.

  Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope.  The act of
running a program using the Library is not restricted, and output from
such a program is covered only if its contents constitute a work based
on the Library (independent of the use of the Library in a tool for
writing it).  Whether that is true depends on what the Library does
and what the program that uses the Library does.
  
  1. You may copy and distribute verbatim copies of the Library's
complete source code as you receive it, in any medium, provided that
you conspicuously and appropriately publish on each copy an
appropriate copyright notice and disclaimer of warranty; keep intact
all the notices that refer to this License and to the absence of any
warranty; and distribute a copy of this License along with the
Library.

  You may charge a fee for the physical act of transferring a copy,
and you may at your option offer warranty protection in exchange for a
fee.

  2. You may modify your copy or copies of the Library or any portion
of it, thus forming a work based on the Library, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:

    a) The modified work must itself be a software library.

    b) You must cause the files modified to carry prominent notices
    stating that you changed the files and the date of any change.

    c) You must cause the whole of the work to be licensed at no
    charge to all third parties under the terms of this License.

    d) If a facility in the modified Library refers to a function or a
    table of data to be supplied by an application program that uses
    the facility, other than as an argument passed when the facility
    is invoked, then you must make a good faith effort to ensure that,
    in the event an application does not supply such function or
    table, the facility still operates, and performs whatever part of
    its purpose remains meaningful.

    (For example, a function in a library to compute square roots has
    a purpose that is entirely well-defined independent of the
    application.  Therefore, Subsection 2d requires that any
    application-supplied function or table used by this function must
    be optional: if the application does not supply it, the square
    root function must still compute square roots.)

These requirements apply to the modified work as a whole.  If
identifiable sections of that work are not derived from the Library,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works.  But when you
distribute the same sections as part of a whole which is a work based
on the Library, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote
it.

Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Library.

In addition, mere aggregation of another work not based on the Library
with the Library (or with a work based on the Library) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.

  3. You may opt to apply the terms of the ordinary GNU General Public
License instead of this License to a given copy of the Library.  To do
this, you must alter all the notices that refer to this License, so
that they refer to the ordinary GNU General Public License, version 2,
instead of to this License.  (If a newer version than version 2 of the
ordinary GNU General Public License has appeared, then you can specify
that version instead if you wish.)  Do not make any other change in
these notices.

  Once this change is made in a given copy, it is irreversible for
that copy, so the ordinary GNU General Public License applies to all
subsequent copies and derivative works made from that copy.

  This option is useful when you wish to copy part of the code of
the Library into a program that is not a library.

  4. You may copy and distribute the Library (or a portion or
derivative of it, under Section 2) in object code or executable form
under the terms of Sections 1 and 2 above provided that you accompany
it with the complete corresponding machine-readable source code, which
must be distributed under the terms of Sections 1 and 2 above on a
medium customarily used for software interchange.

  If distribution of object code is made by offering access to copy
from a designated place, then offering equivalent access to copy the
source code from the same place satisfies the requirement to
distribute the source code, even though third parties are not
compelled to copy the source along with the object code.

  5. A program that contains no derivative of any portion of the
Library, but is designed to work with the Library by being compiled or
linked with it, is called a "work that uses the Library".  Such a
work, in isolation, is not a derivative work of the Library, and
therefore falls outside the scope of this License.

  However, linking a "work that uses the Library" with the Library
creates an executable that is a derivative of the Library (because it
contains portions of the Library), rather than a "work that uses the
library".  The executable is therefore covered by this License.
Section 6 states terms for distribution of such executables.

  When a "work that uses the Library" uses material from a header file
that is part of the Library, the object code for the work may be a
derivative work of the Library even though the source code is not.
Whether this is true is especially significant if the work can be
linked without the Library, or if the work is itself a library.  The
threshold for this to be true is not precisely defined by law.

  If such an object file uses only numerical parameters, data
structure layouts and accessors, and small macros and small inline
functions (ten lines or less in length), then the use of the object
file is unrestricted, regardless of whether it is legally a derivative
work.  (Executables containing this object code plus portions of the
Library will still fall under Section 6.)

  Otherwise, if the work is a derivative of the Library, you may
distribute the object code for the work under the terms of Section 6.
Any executables containing that work also fall under Section 6,
whether or not they are linked directly with the Library itself.

  6. As an exception to the Sections above, you may also combine or
link a "work that uses the Library" with the Library to produce a
work containing portions of the Library, and distribute that work
under terms of your choice, provided that the terms permit
modification of the work for the customer's own use and reverse
engineering for debugging such modifications.

  You must give prominent notice with each copy of the work that the
Library is used in it and that the Library and its use are covered by
this License.  You must supply a copy of this License.  If the work
during execution displays copyright notices, you must include the
copyright notice for the Library among them, as well as a reference
directing the user to the copy of this License.  Also, you must do one
of these things:

    a) Accompany the work with the complete corresponding
    machine-readable source code for the Library including whatever
    changes were used in the work (which must be distributed under
    Sections 1 and 2 above); and, if the work is an executable linked
    with the Library, with the complete machine-readable "work that
    uses the Library", as object code and/or source code, so that the
    user can modify the Library and then relink to produce a modified
    executable containing the modified Library.  (It is understood
    that the user who changes the contents of definitions files in the
    Library will not necessarily be able to recompile the application
    to use the modified definitions.)

    b) Use a suitable shared library mechanism for linking with the
    Library.  A suitable mechanism is one that (1) uses at run time a
    copy of the library already present on the user's computer system,
    rather than copying library functions into the executable, and (2)
    will operate properly with a modified version of the library, if
    the user installs one, as long as the modified version is
    interface-compatible with the version that the work was made with.

    c) Accompany the work with a written offer, valid for at
    least three years, to give the same user the materials
    specified in Subsection 6a, above, for a charge no more
    than the cost of performing this distribution.

    d) If distribution of the work is made by offering access to copy
    from a designated place, offer equivalent access to copy the above
    specified materials from the same place.

    e) Verify that the user has already received a copy of these
    materials or that you have already sent this user a copy.

  For an executable, the required form of the "work that uses the
Library" must include any data and utility programs needed for
reproducing the executable from it.  However, as a special exception,
the materials to be distributed need not include anything that is
normally distributed (in either source or binary form) with the major
components (compiler, kernel, and so on) of the operating system on
which the executable runs, unless that component itself accompanies
the executable.

  It may happen that this requirement contradicts the license
restrictions of other proprietary libraries that do not normally
accompany the operating system.  Such a contradiction means you cannot
use both them and the Library together in an executable that you
distribute.

  7. You may place library facilities that are a work based on the
Library side-by-side in a single library together with other library
facilities not covered by this License, and distribute such a combined
library, provided that the separate distribution of the work based on
the Library and of the other library facilities is otherwise
permitted, and provided that you do these two things:

    a) Accompany the combined library with a copy of the same work
    based on the Library, uncombined with any other library
    facilities.  This must be distributed under the terms of the
    Sections above.

    b) Give prominent notice with the combined library of the fact
    that part of it is a work based on the Library, and explaining
    where to find the accompanying uncombined form of the same work.

  8. You may not copy, modify, sublicense, link with, or distribute
the Library except as expressly provided under this License.  Any
attempt otherwise to copy, modify, sublicense, link with, or
distribute the Library is void, and will automatically terminate your
rights under this License.  However, parties who have received copies,
or rights, from you under this License will not have their licenses
terminated so long as such parties remain in full compliance.

  9. You are not required to accept this License, since you have not
signed it.  However, nothing else grants you permission to modify or
distribute the Library or its derivative works.  These actions are
prohibited by law if you do not accept this License.  Therefore, by
modifying or distributing the Library (or any work based on the
Library), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Library or works based on it.

  10. Each time you redistribute the Library (or any work based on the
Library), the recipient automatically receives a license from the
original licensor to copy, distribute, link with or modify the Library
subject to these terms and conditions.  You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties with
this License.

  11. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Library at all.  For example, if a patent
license would not permit royalty-free redistribution of the Library by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Library.

If any portion of this section is held invalid or unenforceable under any
particular circumstance, the balance of the section is intended to apply,
and the section as a whole is intended to apply in other circumstances.

It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system which is
implemented by public license practices.  Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.

This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.

  12. If the distribution and/or use of the Library is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Library under this License may add
an explicit geographical distribution limitation excluding those countries,
so that distribution is permitted only in or among countries not thus
excluded.  In such case, this License incorporates the limitation as if
written in the body of this License.

  13. The Free Software Foundation may publish revised and/or new
versions of the Lesser General Public License from time to time.
Such new versions will be similar in spirit to the present version,
but may differ in detail to address new problems or concerns.

Each version is given a distinguishing version number.  If the Library
specifies a version number of this License which applies to it and
"any later version", you have the option of following the terms and
conditions either of that version or of any later version published by
the Free Software Foundation.  If the Library does not specify a
license version number, you may choose any version ever published by
the Free Software Foundation.

  14. If you wish to incorporate parts of the Library into other free
programs whose distribution conditions are incompatible with these,
write to the author to ask for permission.  For software which is
copyrighted by the Free Software Foundation, write to the Free
Software Foundation; we sometimes make exceptions for this.  Our
decision will be guided by the two goals of preserving the free status
of all derivatives of our free software and of promoting the sharing
and reuse of software generally.

			    NO WARRANTY

  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.

  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
DAMAGES.

		     END OF TERMS AND CONDITIONS

#  Copyright (c) 1993 - 2005 CENA, Patrick Lecoanet --
#
# See the file "Copyright" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# $Revision$
#
#
# This Makefile.in is derived from the Sample TEA template which is:
#
# Copyright (c) 1999 Scriptics Corporation.
# Copyright (c) 2002 ActiveState SRL.
#

PACKAGE_NAME      = @PACKAGE_NAME@
PACKAGE_VERSION   = @PACKAGE_VERSION@

PKG_SOURCES	      = @PKG_SOURCES@
PKG_OBJECTS	      = @PKG_OBJECTS@

PKG_STUB_SOURCES	= @PKG_STUB_SOURCES@
PKG_STUB_OBJECTS	= @PKG_STUB_OBJECTS@

PKG_TCL_SOURCES   = @PKG_TCL_SOURCES@

PKG_HEADERS       = @PKG_HEADERS@

PKG_LIB_FILE      = @PKG_LIB_FILE@
PKG_STUB_LIB_FILE = @PKG_STUB_LIB_FILE@

BINARIES	= $(PKG_LIB_FILE) $(PKG_STUB_LIB_FILE)

SHELL		= @SHELL@

srcdir		= @srcdir@
prefix		= @prefix@
exec_prefix	= @exec_prefix@

libdir		= @libdir@
includedir	= @includedir@

DESTDIR		=

PKG_DIR		= $(PACKAGE_NAME)$(PACKAGE_VERSION)
pkglibdir	= $(libdir)/$(PKG_DIR)

top_builddir	= .

INSTALL		= @INSTALL@
INSTALL_PROGRAM	= @INSTALL_PROGRAM@
INSTALL_DATA	= @INSTALL_DATA@
INSTALL_SCRIPT	= @INSTALL_SCRIPT@

CC		= @CC@
CFLAGS_DEBUG	= @CFLAGS_DEBUG@
CFLAGS_DEFAULT	= @CFLAGS_DEFAULT@
CFLAGS_OPTIMIZE	= @CFLAGS_OPTIMIZE@
CFLAGS_WARNING	= @CFLAGS_WARNING@
CLEANFILES	= @CLEANFILES@
EXEEXT		= @EXEEXT@
LDFLAGS_DEFAULT = @LDFLAGS_DEFAULT@
MAKE_LIB	= @MAKE_LIB@
MAKE_STUB_LIB	= @MAKE_STUB_LIB@
MAKE_SHARED_LIB	= @MAKE_SHARED_LIB@
MAKE_STATIC_LIB	= @MAKE_STATIC_LIB@
OBJEXT		= @OBJEXT@
RANLIB		= @RANLIB@
SHLIB_CFLAGS	= @SHLIB_CFLAGS@
SHLIB_LD	= @SHLIB_LD@
SHLIB_LD_LIBS	= @SHLIB_LD_LIBS@
STLIB_LD	= @STLIB_LD@
TCL_BIN_DIR	= @TCL_BIN_DIR@
TCL_SRC_DIR	= @TCL_SRC_DIR@
TK_BIN_DIR	= @TK_BIN_DIR@
TK_SRC_DIR	= @TK_SRC_DIR@
#
# This is necessary for packages that use private Tcl headers
TCL_TOP_DIR_NATIVE	= @TCL_TOP_DIR_NATIVE@
TK_TOP_DIR_NATIVE	= @TK_TOP_DIR_NATIVE@
# Not used, but retained for reference of what libs Tcl required
TCL_LIBS	= @TCL_LIBS@


#========================================================================
# TCLLIBPATH seeds the auto_path in Tcl's init.tcl so we can test our
# package without installing.  The other environment variables allow us
# to test against an uninstalled Tcl.  Add special env vars that you
# require for testing here (like TCLX_LIBRARY).
#========================================================================

EXTRA_PATH	= $(top_builddir):$(TCL_BIN_DIR)
TCLSH_ENV	= TCL_LIBRARY=`@CYGPATH@ $(TCL_SRC_DIR)/library` \
		  LD_LIBRARY_PATH="$(EXTRA_PATH):$(LD_LIBRARY_PATH)" \
		  LIBPATH="$(EXTRA_PATH):${LIBPATH}" \
		  SHLIB_PATH="$(EXTRA_PATH):${SHLIB_PATH}" \
		  PATH="$(EXTRA_PATH):$(PATH)" \
		  TCLLIBPATH="$(top_builddir)"
TCLSH_PROG	= @TCLSH_PROG@
WISH_PROG	= @WISH_PROG@
TCLSH		= $(TCLSH_ENV) $(TCLSH_PROG)
WISH		= $(TCLSH_ENV) $(WISH_PROG)
SHARED_BUILD	= @SHARED_BUILD@

# The local includes must come first, because the TK_XINCLUDES can be
# just a comment
TCL_INCLUDES = @TCL_INCLUDES@
TK_INCLUDES = @TK_INCLUDES@
GL_INCLUDES = @GL_INCLUDES@
INCLUDES	= -I$(srcdir)/generic @TCL_INCLUDES@ @TK_INCLUDES@ @GL_INCLUDES@

TCL_EXTRA_CFLAGS	= $(MEM_DEBUG_FLAGS) @TCL_EXTRA_CFLAGS@

DEFS		= @DEFS@ @PKG_CFLAGS@ $(TCL_EXTRA_CFLAGS)

CONFIG_CLEAN_FILES = Makefile

CPPFLAGS	= @CPPFLAGS@
LIBS		= @PKG_LIBS@ @LIBS@
AR		= @AR@
CFLAGS		= @CFLAGS@
COMPILE		= $(CC) $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)


#
# No stubs build right now
#all: package libraries
all: package

package: $(PKG_LIB_FILE) pkgIndex.tcl

libraries: $(PKG_STUB_LIB_FILE)


#========================================================================
# The doc target is for building man pages. Currently the zinc doc is
# only available in html and pdf formats. These formats require tools
# (LaTeX, pdfTeX, h4tex) that are not readily available on all
# platforms. To ease automatic construction of the package the target
# doc does not involve the construction of pdf and html.
#========================================================================

doc:

doc-clean:
	(cd doc; \
				rm -f refman.aux refman.idx refman.ind refman.lof refman.lot; \
				rm -f refman.log refman.out refman.toc texput.log refman.tpt; \
				rm -f idxmake.dvi idxmake.log refman.4ct refman.4dx refman.4ix; \
				rm -f refman.4tc refman.dvi refman.idx refman.ilg refman.ind; \
				rm -f refman.log refman.tmp refman.xref refman.lg refman.idv)

pdf: doc-clean doc/refman.tex
	(cd doc; \
	  pdflatex refman.tex; \
		makeindex -o refman.ind refman.idx; \
	  pdflatex refman.tex; \
	  pdflatex refman.tex)

html: doc-clean doc/refman.tex
	(cd doc; \
	  htlatex refman.tex refman; \
	  tex '\def\filename{{refman}{idx}{4dx}{ind}}' '\input' idxmake.4ht; \
		makeindex -o refman.ind refman.4dx; \
		htlatex refman.tex refman)

#
# No stubs and no headers installed right now
#install: install-package install-libraries install-headers install-demos
install: install-package install-demos

install-package:
	@mkdir -p $(DESTDIR)$(pkglibdir)
	$(INSTALL_PROGRAM) $(PKG_LIB_FILE) $(DESTDIR)$(pkglibdir)/$(PKG_LIB_FILE)
	for p in $(srcdir)/library/*.tcl ; do \
		destp=`basename $$p`; \
		echo " Install $$destp $(DESTDIR)$(pkglibdir)/$$destp"; \
		$(INSTALL_DATA) $$p $(DESTDIR)$(pkglibdir)/$$destp; \
	done
	cat pkgIndex.tcl >> $(DESTDIR)$(pkglibdir)/pkgIndex.tcl

install-headers:
	echo "Installing header files in $(DESTDIR)$(includedir)"; \
	mkdir -p $(DESTDIR)$(includedir); \
	for i in "$(PKG_HEADERS)" ; do \
		echo "Install $(srcdir)/$$i" ; \
		destp=`basename $$i`; \
		$(INSTALL_DATA) $(srcdir)/$$i $(DESTDIR)$(includedir)/$$destp ; \
	done

install-libraries:
	@echo "Installing $(PKG_STUB_LIB_FILE) in $(DESTDIR)$(libdir)"
	@mkdir -p $(DESTDIR)$(libdir)
	$(INSTALL_PROGRAM) $(PKG_STUB_LIB_FILE) $(DESTDIR)$(libdir)

install-demos:
	@mkdir -p $(DESTDIR)$(pkglibdir)/demos
	@echo "Installing demo files in $(DESTDIR)$(pkglibdir)/demos"
	@for p in $(srcdir)/demos/*; do \
		p=`basename $$p`; \
		echo " Install $$p $(DESTDIR)$(pkglibdir)/demos/$$p"; \
		$(INSTALL_DATA) $(srcdir)/demos/$$p $(DESTDIR)$(pkglibdir)/demos/$$p; \
	done
	@mkdir -p $(DESTDIR)$(pkglibdir)/demos/images
	@mkdir -p $(DESTDIR)$(pkglibdir)/demos/data
	@for p in $(srcdir)/demos/images/*; do \
		p=`basename $$p`; \
		echo " Install $$p $(DESTDIR)$(pkglibdir)/demos/images/$$p"; \
		$(INSTALL_DATA) $(srcdir)/demos/images/$$p $(DESTDIR)$(pkglibdir)/demos/images/$$p; \
	done
	@for p in $(srcdir)/demos/data/*; do \
		p=`basename $$p`; \
		echo " Install $$p $(DESTDIR)$(pkglibdir)/demos/data/$$p"; \
		$(INSTALL_DATA) $(srcdir)/demos/data/$$p $(DESTDIR)$(pkglibdir)/demos/data/$$p; \
	done

test: package libraries
	$(TCLSH) `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) ; \

shell: package libraries
	@$(TCLSH) $(SCRIPT)

gdb:
	$(TCLSH_ENV) gdb $(TCLSH_PROG) $(SCRIPT)

depend:

$(PKG_LIB_FILE): $(PKG_OBJECTS)
	-rm -f $(PKG_LIB_FILE)
	${MAKE_LIB}
	$(RANLIB) $(PKG_LIB_FILE)

$(PKG_STUB_LIB_FILE): $(PKG_STUB_OBJECTS)
	-rm -f $(PKG_STUB_LIB_FILE)
	${MAKE_STUB_LIB}
	$(RANLIB) $(PKG_STUB_LIB_FILE)
  
#========================================================================
# We need to enumerate the list of .c to .o lines here.
#
# In the following lines, $(srcdir) refers to the toplevel directory
# containing your extension.  If your sources are in a subdirectory,
# you will have to modify the paths to reflect this:
#
# sample.$(OBJEXT): $(srcdir)/generic/sample.c
# 	$(COMPILE) -c `@CYGPATH@ $(srcdir)/generic/sample.c` -o $@
#
# Setting the VPATH variable to a list of paths will cause the makefile
# to look into these paths when resolving .c to .obj dependencies.
# As necessary, add $(srcdir):$(srcdir)/compat:....
#========================================================================

VPATH = $(srcdir):$(srcdir)/generic:$(srcdir)/unix:$(srcdir)/win:$(srcdir)/macosx

.SUFFIXES: .c .$(OBJEXT)

.c.$(OBJEXT):
	$(COMPILE) -c `@CYGPATH@ $<` -o $@

#========================================================================
# Create the pkgIndex.tcl file.
# It is usually easiest to let Tcl do this for you with pkg_mkIndex, but
# you may find that you need to customize the package.  If so, either
# modify the -hand version, or create a pkgIndex.tcl.in file and have
# the configure script output the pkgIndex.tcl by editing configure.in.
#========================================================================

pkgIndex.tcl:
	(echo 'package ifneeded $(PACKAGE_NAME) $(PACKAGE_VERSION) \
	    [list load [file join $$dir $(PKG_LIB_FILE)]]'\
	) > pkgIndex.tcl

#========================================================================
# Don't modify the file to clean here.  Instead, set the "CLEANFILES"
# variable in configure.in
#========================================================================

clean: doc-clean 
	-test -z "$(BINARIES)" || rm -f $(BINARIES)
	-rm -f *.$(OBJEXT) core *.core
	-test -z "$(CLEANFILES)" || rm -Rf $(CLEANFILES)

distclean: clean
	-rm -f *.tab.c *~
	-rm -f $(CONFIG_CLEAN_FILES)
	-rm -f config.cache config.log config.status

#========================================================================
# Install binary object libraries.  On Windows this includes both .dll and
# .lib files.  Because the .lib files are not explicitly listed anywhere,
# we need to deduce their existence from the .dll file of the same name.
# Library files go into the lib directory.
# In addition, this will generate the pkgIndex.tcl
# file in the install location (assuming it can find a usable tclsh shell)
#
# You should not have to modify this target.
#========================================================================

Makefile: $(srcdir)/Makefile.in  $(top_builddir)/config.status
	cd $(top_builddir) \
	  && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status

.PHONY: all package clean depend distclean doc install libraries test

# Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.
.NOEXPORT:

use 5.006;
use Tk;
use Config;
use Tk::Config;
use ExtUtils::MakeMaker;
use strict;

my $TkLibDir = $Tk::library;
my $platform = $Tk::platform;

my $VERSION = SEEexport2cpan;


if (!$TkLibDir)
{
    print stderr "==================================================================\n";
    print stderr "Could not find the Perl/Tk (pTk) library.\n";
    print stderr "Please, install first Perl/Tk interface before installing Tk::Zinc\n";
    print stderr "==================================================================\n";
    die;
}


print "Configuring version $VERSION for $platform platform...\n";
print "Using $TkLibDir as Tk library...\n";

my @GENERIC_C = ('Tabular.c', 'Rectangle.c', 'Arc.c', 'Curve.c',
		 'Item.c', 'PostScript.c', 'Attrs.c', 'Draw.c', 'Geo.c', 'List.c',
		 'perfos.c', 'Transfo.c', 'Group.c', 'Icon.c', 'Text.c', 'Image.c', 'Color.c',
		 'Field.c', 'Triangles.c', 'Viewport.c', 'WindowUtils.c', 'Window.c', 'tkZinc.c');

my @ATC_C = ('OverlapMan.c', 'Track.c', 'Reticle.c', 'Map.c', 'MapInfo.c');

my @WIN_C = ('WinPort.c');

my @C;

my $WIN = ($platform =~ /win/i);

push @C, @GENERIC_C ;

my $NeededLibs = ['-L/usr/X11R6/lib -lXext -lX11 -lGLU -lGL -L.'];

if ($WIN) {
    push @C, @WIN_C;
    $NeededLibs = ['-lglu32 -lopengl32']
}
my $ZincObj = "Zinc" . $Config{"_o"};

my $INC = "-I. -I$TkLibDir -I$TkLibDir/pTk -I$TkLibDir/X11";

unless ($WIN) {
  $INC .= " -I/usr/X11R6/include";
}

#For some reason which the author of ExtUtils::MM_Unix forget, Unix machines like to have
#PERL_DL_NONLAZY set for tests. This is FALSE for TkZinc.

if ($] >= 5.008000) {
  *ExtUtils::MM_Unix::test_via_harness = sub {
    my($self, $perl, $tests) = @_;
#    return $self->SUPER::test_via_harness("PERL_DL_NONLAZY=1 $perl", $tests);
    # I should use the SUPER method, but this needs some import tunning...
    return ExtUtils::MM_Any::test_via_harness($self, $perl, $tests);
  };

#Again, the PERL_DL_NONLAZY thing.
  *ExtUtils::MM_Unix::test_via_script = sub {
    my($self, $perl, $script) = @_;
#    return $self->SUPER::test_via_script("PERL_DL_NONLAZY=1 $perl", $script);
    # I should use the SUPER method, but this needs some import tunning...
    return ExtUtils::MM_Any::test_via_script($self, $perl, $script);
  };
}

# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.

my $mm_ver = $ExtUtils::MakeMaker::VERSION;
if ($mm_ver =~ /_/) { # dev version
    $mm_ver = eval $mm_ver;
    die $@ if $@;
}

WriteMakefile(
    'ABSTRACT'      => 'a canvas offering groups, tranformations, transparency, color gradient...',
    'AUTHOR'        => 'Patrick Lecoanet <lecoanet@cena.fr>',
    'NAME'          => 'Tk::Zinc',
    'PREREQ_PM'     => $WIN ? {Tk => 8.004} : {Tk => 8.0},
    'LIBS'          => $NeededLibs, 
    'OPTIMIZE'      => &optimize,
    'DEFINE'        => &get_flags,
    'INC'           => $INC,
    'C'             => [@C],
    'XS_VERSION'    => $Tk::Config::VERSION,
    'XS'            => {'Zinc.xs' => 'Zinc.c'},
    'linkext'       => {LINKTYPE => 'dynamic'},
    'depend'        => {$ZincObj => '$(O_FILES) Zinc.c'},
    'LDFROM'        => "\$(O_FILES) $ZincObj",
    ($mm_ver <= 6.45
        ? ()
        : (META_MERGE => {
            'meta-spec' => { version => 2 },
            resources => {
                repository  => {
                    type => 'hg',
                    web  => 'https://bitbucket.org/plecoanet/tkzinc',
                    url  => 'https://bitbucket.org/plecoanet/tkzinc/src',
                },
            },
          })
    ),
);

sub optimize {
  foreach my $arg (@ARGV) {
    if ($arg =~ /(enable-symbols)/i) {
      return "-g";
    }
  }
  return "-O";
}

sub get_flags {
    my %DEF_FLAGS = ('GL'        => 1,
		     'SHAPE'     => 1,
		     'ATC'        => 1
		     );
    
    foreach my $arg (@ARGV) {
	print "$arg ....\n";
	my ($name, $value) = split(/[=]+/, $arg);
	if ($name =~ /(with-gl)/i) {
	    if ($value =~ /no/i) {
		$DEF_FLAGS{'GL'} = 0;
	    }
	}
	elsif ($name =~ /(with-atc)/i) {
	    if ($value =~ /no/i) {
		$DEF_FLAGS{'ATC'} = 0;
	    }
	}
	elsif ($name =~ /(with-shape)/i) {
	    if ($value =~ /no/i) {
		$DEF_FLAGS{'SHAPE'} = 0;
	    }
	}
    }
    
    my $defines = "-DPTK -DPACKAGE_VERSION=\\\"$VERSION\\\"";

    if ($WIN) {
	#
	# No shape extension on Windows (planned later).
	$DEF_FLAGS{'SHAPE'} = 0;
	#
	# Visual C++ does not define __STDC__ by default
	$defines .= ' -D__STDC__';
    }

    print "Configuring with:\n    ";
    foreach my $flag (keys %DEF_FLAGS) {
	print "$flag=", $DEF_FLAGS{$flag} ? 'ok' : 'no', " ";
	if ($DEF_FLAGS{$flag}) {	    
	    $defines = $defines . " " . "-D$flag";
	    if ($flag eq 'ATC') {
		push @C, @ATC_C
	    }
	}
    }
    if ($Tk::VERSION =~ /^800/) {
      $defines .= " -DPTK_800";
      print "PTK=800";
    } else {
      print "PTK=804";
    }
    print "\n";
    return $defines;
}

#
# For the demo
#
# perl -Mblib demos/zinc-demos

Tk::Zinc - another Canvas which proposes many new functions, some based on openGL

Tk::Zinc for Perl/Tk is available for Linux, Windows and MacOSX. 
the easiest way could be to use he CPAN. However new releases are usually 
first available on www.tkzinc.org
To build it you need:

* On a Linux system, you need Perl (>= 5.6) and perl-tk (800 or 804) as well as
  perl-tk developpement packages.

* On MacOSX you need:
  - fink with tk-pm package and its dependencies (http://fink.sf.net)
    tk-pm is available in unstable. You can add this binary unstable tree to you /sw/etc/apt/sources.list:
    deb http://fink.opendarwin.org/bbraun 10.3/unstable main crypto
    deb http://fink.opendarwin.org/bbraun 10.3/stable main crypto
  - X11 et X11 sdk from Apple (http://www.apple.com/macosx/x11/)

* On WinXP you need:
  - activeperl (5.8.6.811 or higher) from activatestate.com 
  - and
    - if you want to compile TkZinc by yourself:
      Visual C++ or the Free Visual C++ Command Line Tools
    - or the TkZinc msi package available from www.tkzinc.org


Install:

  perl Makefile.PL
  # you can use the following options: --with-gl=yes|no --with-atc=yes|no --with-shape=yes|no
  # current defaults are  --with-gl=yes --with-atc=yes --with-shape=yes

  make
  make test

  # to run demos before installing:
  perl -Iblib/arch -Iblib/lib demos/zinc-demos

  make install



WATCH OUT! On Linux it is quite frequent to have both Mesa and proprietary
           openGL libraries installed. This may lead to big problems at
           runtime if the linker picks the wrong library. It is often the
           the case between the static (libGL.a) Mesa library and the dynamic
           (libGL.so) NVidia library. It is very important to assert that
           the link is done with the library matching the openGL driver
           loaded in the X server.

In the case you need to use another version of perl-tk than the one installed in the 
system, you should use the following command as a template to adapt to follow your 
specific pathes of the alternative perl-tk installation:

  env PERL5LIB=/usr/local/test/804_027/lib/perl5/site_perl/5.8.1/i386-linux-thread-multi perl Makefile.PL
  make
  env PERL5LIB=/usr/local/test/804_027/lib/perl5/5.8.1/i386-linux-thread-multi:/usr/local/test/804_027/lib/perl5/site_perl/5.8.1/i386-linux-thread-multi make test

  # to run demos before installing:
  env PERL5LIB=/usr/local/test/804_027/lib/perl5/5.8.1/i386-linux-thread-multi:/usr/local/test/804_027/lib/perl5/site_perl/5.8.1/i386-linux-thread-multi perl -Iblib/arch -Iblib/lib demos/zinc-demos

  # and finally
  make install

  # and to run your script:
  env PERL5LIB=/usr/local/test/804_027/lib/perl5/5.8.1/i386-linux-thread-multi:/usr/local/test/804_027/lib/perl5/site_perl/5.8.1/i386-linux-thread-multi perl <your_script.pl>




up-to-date documentation is also available at https://bitbucket.org/plecoanet/tkzinc
The source of the reference manual is available in the full source package,
which also includes TkZinc for Tcl/Tk, for Perl/Tk, and for Python.


After installation, we recommend you to launch the zinc-demos script,
a frontend to more than 30 small demos.

For more information on building Tk::Zinc, a README is available in 
the tkzinc-*tgz tar file (on Tkzinc web site) used for building all
flavor of TkZinc (ie tcl, perl and python)

This software is delivered under new  BSD licence.
For the copyright, please, read the Copyright file.

For any question on Tk::Zinc usage, build or installation pb,
please create an inquiry on Bitbucket: https://bitbucket.org/plecoanet/tkzinc/issues


Authors and Contributors:

Tk::Zinc main author is Patrick Lecoanet (CENA)
Sub-Modules, demos and documentation have been developped by
Daniel Etienne (CENA), Christophe Mertz (formerly CENA and now IntuiLab), 
Jean-Luc Vinot (CENA), with contributions from Stéphane Chatty (Intuilab), 
Céline Schlienger (IntuiLab), Alexandre Lemort (IntuiLab)
Stéphane Conversy (CENA) contributed to the MacOSX port.
Many others contributed with their bug reports!

# $Id$
# $Name$

package Tk::Zinc;

use Tk;
use Tk::Photo;
use Carp;

use base qw(Tk::Widget); 
Construct Tk::Widget 'Zinc';


use vars qw($VERSION $REVISION);

$REVISION = q$Revision$ ;  # this line is automagically modified by CVS
$VERSION = SEEexport2cpan;


bootstrap Tk::Zinc $Tk::VERSION;

sub Tk_cmd { \&Tk::zinc }

sub CreateOptions
{
 return (shift->SUPER::CreateOptions,'-render')
}

Tk::Methods("add", "addtag", "anchorxy", "bbox", "becomes", "bind", "cget",
	    "chggroup", "clone", "collapsemotions", "configure", "contour", "coords",
      "currentpart", "cursor", "dchars", "dtag", "find", "fit", "focus",
      "gdelete", "gettags", "gname", "group", "hasanchors", "hasfields",
      "hastag", "index", "insert", "itemcget", "itemconfigure", "lower",
      "monitor", "numparts", "postscript", "raise", "remove", "rotate",
      "scale", "select", "skew", "smooth", "tapply", "tcompose", "tdelete",
      "tget", "transform", "translate", "treset", "trestore", "tsave", "tset",
	    "type", "vertexat", "xview", "yview");

## coord0 is a compatibility function usefull for porting old application
## previously running with Tk::Zinc V <= 3.2.6a
## The Zinc methode coords0 can/should replace coords as long as no control points are
## used in curve or rectangle or an arc...
## This can dramaticaly simplify the port of an old application from Zinc V<3.2.6a to
## a newer version of Zinc. HOWEVER YOU STILL MUST CHANGE THE CODE OF THIS OLD APPICATION
##
## Remember: the incompatible change in Zinc is due to the introduction of
## control points in curves (and a future release, in arc or rectangle items...)
sub coords0 {
    if (wantarray) {
	## we are in list context, so we should convert the returned value
	## to match the specification of Zinc Version <= 3.2.6a
	my @res = &Tk::Zinc::coords(@_);
	if ( !ref $res[0] ) {
	    ## The first item of the list is not a reference, so the
	    ## list is guarranted to be a flat list (x, y, x, y, ... x, y)
	    return @res;
	}
	else {
	    ## The list is a list of references like : [x y] or [x y symbol] 
	    ## In the latter case, coord0 should warn that there is a control point!
	    ## coord0 will return a flatten list of (x, y, ... x , y)
	    my @res0;
	    foreach my $ref (@res) {
		my @array = @{$ref};
	        if ($#array > 1) {
		   my $item = $_[1];
		   my $zinc = $_[0];
		   my $type = $zinc->type($item);
		   carp "Using Zinc coord0 compatibility method with item $item (type=$type) which contains a control point: @array";
	        }
		push @res0, $array[0];
		push @res0, $array[1];
	    }
	    return @res0;
        }
    }
    else {
	## contexte scalaire
	## le résultat n'était pas utilisé jusqu'à présent, vu le bug...
	## donc inutile de le convertir!
	return &Tk::Zinc::coords(@_);
    }
}

1;

__END__

=head1 NAME

Tk::Zinc - TkZinc is another Canvas which proposes many new functions, some based on openGL

=for category Tk Widget Classes

=head1 SYNOPSIS

I<$zinc> = I<$parent>-E<gt>B<Zinc>(?I<options>?);

=head1 DESCRIPTION

I<Zinc> widget is very similar to Tk Canvase in that it supports
structured graphics. Like the Canvas, TkZinc implements items used to
display graphical entities. Those items can be manipulated and bindings can be
associated with them to implement interaction behaviors. But unlike the
Canvas, TkZinc can structure the items in a hierarchy (with the use of
group items), has support for affine 2D transforms (i.e. translation, scaling, and
rotation), clipping can be set for sub-trees of the item hierarchy, the item set
is quite more powerful including field specific items for Air Traffic systems and
new rendering techniques such as transparency and gradients.

Since the 3.2.2 version, TkZinc also offers as a runtime option, the support
for openGL rendering, giving access to features such as antialiasing, transparency,
color gradients and even a new, openGL oriented, item type triangles.

TkZinc full documentation is available as part of the Zinc software as a
pdf file, B<refman.pdf> and html pages B<refman/index.html>.

As a complement to the reference manual, small Perl/Tk demos of TkZinc are
also available through a small application named zinc-demos, highly inspired
from the widget application included in Tk. The aim of these demos are both
to demonstrates the power of TkZinc and to help newcomers start using
TkZinc with small examples.

=head1 WHERE CAN I FIND TkZinc?

TkZinc is available as source in tar.gz format at L<https://bitbucket.org/plecoanet/tkzinc>.
There is some old packages at http://freshmeat.net/projects/zincisnotcanvas/, but please use the Bitbucket repo.

TkZinc is also available on CPAN since v3.294 (a kind of 3.2.94)

=head1 AUTHOR

Patrick Lecoanet <lecoanet@cena.fr>

=head1 COPYRIGHT

Zinc has been developed by the CENA (Centres d'Etudes de la Navigation
Aérienne) for its own needs in advanced HMI (Human Machine Interfaces or Interactions).
Because we are confident in the benefit of free software, the CENA delivered this
toolkit under the GNU Library General Public License.

This code is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Library General Public License for more details.

Parts of this software are derived from the Tk toolkit which is copyrighted
under another open source license by The Regents of the University of California
and Sun Microsystems, Inc. The GL
font rendering is derived from Mark Kilgard code described in 'A Simple OpenGL-based
API for Texture Mapped Text' and is copyrighted by Mark Kilgard under an open source license.

=head1 SEE ALSO

L<Tk(1)>, L<zinc-demos(1)>.

=cut

/*
  Copyright (c) 1995-1997 Nick Ing-Simmons. All rights reserved.
  This program is free software; you can redistribute it and/or
  modify it under the same terms as Perl itself.
*/

#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>

#include <tkGlue.def>

#include <pTk/tkPort.h>
#include <pTk/tkInt.h>
#ifdef _WIN32
#include <pTk/tkWinInt.h>
#endif
#include <pTk/tkImgPhoto.h>
#include <pTk/tkVMacro.h>
#include <tkGlue.h>
#include <tkGlue.m>

extern int
ZincObjCmd(
	   ClientData client_data,
	   Tcl_Interp* interp,
	   int argc,
	   Tcl_Obj* CONST args[]);

extern int
ZnVideomapObjCmd(
	         ClientData client_data,
	         Tcl_Interp* interp,
	         int argc,
	         Tcl_Obj* CONST args[]);

extern int
ZnMapInfoObjCmd(
	        ClientData client_data,
	        Tcl_Interp* interp,
	        int argc,
	        Tcl_Obj* CONST args[]);

DECLARE_VTABLES;
TkimgphotoVtab *TkimgphotoVptr;

MODULE = Tk::Zinc	PACKAGE = Tk::Zinc

PROTOTYPES: DISABLE

BOOT:
 {
  IMPORT_VTABLES;
  TkimgphotoVptr = (TkimgphotoVtab *) SvIV(perl_get_sv("Tk::TkimgphotoVtab",GV_ADDWARN|GV_ADD));

  Lang_TkCommand("zinc", ZincObjCmd);
  Lang_TkCommand("videomap", ZnVideomapObjCmd);
  Lang_TkCommand("mapinfo", ZnMapInfoObjCmd);
 }

#        Tk::Zinc::Debug Perl Module :
#
#        For debugging/analysing a Zinc application.
#
#        Author : Daniel Etienne <etienne@cena.fr>
#
# $Id$
#---------------------------------------------------------------------------
package Tk::Zinc::Debug;

use vars qw( $VERSION );
($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/);

use strict 'vars';
use vars qw(@ISA @EXPORT @EXPORT_OK $WARNING $endoptions);
use Carp;
use English;
require Exporter;
use File::Basename;
use Tk::Dialog;
use Tk::Tree;
use Tk::ItemStyle;
use Tk::Pane;
use Tk::FBox;
use Tk::Balloon;

@ISA = qw(Exporter);
@EXPORT = qw(finditems snapshot tree init);
@EXPORT_OK = qw(finditems snapshot tree init);

my ($itemstyle, $groupstyle, $step);
my (%result_tl, $result_fm, $search_tl, $helptree_tl, %coords_tl, %transfo_tl,
    $helpcoords_tl, $searchtree_tl, $tree_tl, %alloptions_tl, $tree,
    $cursorxy_tl, $cursorxy);
my $showitemflag;
my ($x0, $y0);
my ($help_print, $imagecounter, $saving) = (0, 0, 0);
my %searchEntryValue;
my $searchTreeEntryValue;
my %wwidth;
my %wheight;
my $preload;
my %defaultoptions;
my %instances;
my @instances;
my %cmdoptions;
my $initobjectfunction;
my %userbindings;
my $selectedzinc;
my $control_tl;
my %button;
my %on_command;
my %off_command;
my @znpackinfo;
my $screenwidth;
my $balloonhelp;
#---------------------------------------------------------------------------
#
# Initialisation functions for plugin usage
#
#---------------------------------------------------------------------------

# Hack to overload the Tk::Zinc::InitObject method
#
BEGIN {
    
    # test if Tk::Zinc::Debug is loaded using the -M perl option
    $preload = 1 if (caller(2))[2] == 0;
    return unless $preload;
    # parse Tk::Zinc::Debug options
    require Getopt::Long;
    Getopt::Long::Configure('pass_through');
    Getopt::Long::GetOptions(\%cmdoptions, 'optionsToDisplay=s', 'optionsFormat=s',
			     'snapshotBasename=s', 'expandTagsField=i');
    # save current Tk::Zinc::InitObject function; it will be invoked in
    # overloaded one (see below)
    use Tk;
    use Tk::Zinc;
    $initobjectfunction = Tk::Zinc->can('InitObject');
    
} # end BEGIN


# Hack to capture the instance(s) of zinc. Tk::Zinc::Debug init function
# is invoked here.
#
sub Tk::Zinc::InitObject {
    
    # invoke function possibly overloaded in other modules
    &$initobjectfunction(@_) if $initobjectfunction;
    return unless $preload;
    my $zinc = $_[0];
    &init($zinc);
   
} # end Tk::Zinc::InitObject


#---------------------------------------------------------------------------
#
# Initialisation function
#
#---------------------------------------------------------------------------

sub init {

    my $zinc = shift;
    $screenwidth = $zinc->screenwidth;
    my %options = @_;
    for my $opt (keys(%options)) {
        carp "in Tk::Zinc::Debug initialisation function, unknown option $opt\n"
            unless $opt eq '-optionsToDisplay' or $opt eq '-optionsFormat'
		or $opt eq '-snapshotBasename' or $opt eq '-expandTagsField' ;
    }
    $cmdoptions{optionsToDisplay} = $options{-optionsToDisplay} if
	not defined $cmdoptions{optionsToDisplay} and
	    defined $options{-optionsToDisplay};
    $cmdoptions{optionsFormat} = $options{-optionsFormat} if
	not defined $cmdoptions{optionsFormat} and
	    defined $options{-optionsFormat};
    $cmdoptions{snapshotBasename} = $options{-snapshotBasename} if
	not defined $cmdoptions{snapshotBasename} and
	    defined $options{-snapshotBasename};
    $cmdoptions{expandTagsField} = $options{-expandTagsField} if
	not defined $cmdoptions{expandTagsField} and
	    defined $options{-expandTagsField};
	
    &newinstance($zinc);
    return if Tk::Exists($control_tl);
    print "Tk::Zinc::Debug is ON\n";
    my $bitmaps = &createBitmaps($zinc);
    $control_tl = $zinc->Toplevel;
    $control_tl->title("Tk::Zinc::Debug (V $VERSION)");
    my $fm1 = $control_tl->Frame()->pack(-side => 'left', -padx => 0);
    my $fm2 = $control_tl->Frame()->pack(-side => 'left', -padx => 20);
    my $fm3 = $control_tl->Frame()->pack(-side => 'left', -padx => 0);
    
    for (qw(zn findenclosed findoverlap tree item id snapshot cursorxy)) {
	$button{$_} = $fm1->Checkbutton(-image => $bitmaps->{$_},
					-indicatoron => 0,
					-foreground => 'gray20')->pack(-side => 'left');
    }
    for (qw(zoomminus zoomplus move)) {
	$button{$_} = $fm2->Checkbutton(-image => $bitmaps->{$_},
					-indicatoron => 0,
					-foreground => 'gray20')->pack(-side => 'left');
    }
    for (qw(balloon close)) {
	$button{$_} = $fm3->Checkbutton(-image => $bitmaps->{$_},
					-indicatoron => 0,
					-foreground => 'gray20')->pack(-side => 'left');
    }
    my $bg = $button{zn}->cget(-background);
    for (values(%button)) {
	$_->configure(-selectcolor => $bg);
    }
    $balloonhelp = &balloonhelp();
    $button{balloon}->toggle;
    $control_tl->withdraw();
    $button{zn}->configure(-command => \&focuscommand);
    $button{balloon}->configure(-command => sub {
				    if ($button{balloon}->{Value} == 0) {
					$balloonhelp->configure(-state => 'none');
				    } else {
					$balloonhelp->configure(-state => 'balloon');
				    }
			 });
    #--------------------------------------------------
    # on/off commands for exclusive modes :
    #--------------------------------------------------
    
    # findenclosed mode
    $on_command{findenclosed} = sub {
	&saveDragAndDropBindings($selectedzinc);
	$button{findenclosed}->{Value} = 1;
	$selectedzinc->Tk::bind("<ButtonPress-1>",
				[\&startrectangle, 'simple', 'Enclosed',
				       'sienna']);
	$selectedzinc->Tk::bind("<B1-Motion>", \&resizerectangle);
	$selectedzinc->Tk::bind("<ButtonRelease-1>",
				[\&stoprectangle, 'enclosed',
				 'Items enclosed in rectangle']);
    };
    $off_command{findenclosed} = sub {
	$button{findenclosed}->{Value} = 0;
	&restoreDragAndDropBindings($selectedzinc);
	$selectedzinc->remove("zincdebugrectangle", "zincdebuglabel");
    };
    # findoverlap mode
    $on_command{findoverlap} = sub {
	&saveDragAndDropBindings($selectedzinc);
	$button{findoverlap}->{Value} = 1;
	$selectedzinc->Tk::bind("<ButtonPress-1>", [\&startrectangle, 'mixed',
						    'Overlap', 'sienna']);
	$selectedzinc->Tk::bind("<B1-Motion>", \&resizerectangle);
	$selectedzinc->Tk::bind("<ButtonRelease-1>",
				[\&stoprectangle, 'overlapping',
				 'Items which overlap rectangle']);
    };
    $off_command{findoverlap} = sub {
	$button{findoverlap}->{Value} = 0;
	&restoreDragAndDropBindings($selectedzinc);
	$selectedzinc->remove("zincdebugrectangle", "zincdebuglabel");
    };
    # item mode
    $on_command{item} = sub {
	&saveDragAndDropBindings($selectedzinc);
	$button{item}->{Value} = 1;
	$selectedzinc->Tk::bind("<ButtonPress-1>", [\&findintree]);
    };
    $off_command{item} = sub {
	$button{item}->{Value} = 0;
	&restoreDragAndDropBindings($selectedzinc);
    };
    # cursor device position mode
    $on_command{cursorxy} = sub {
	&saveMotionBinding($selectedzinc);
	$button{cursorxy}->{Value} = 1;
	&cursorxyOpen;
	$selectedzinc->Tk::bind("<Motion>", [\&cursorxy]);
    };
    $off_command{cursorxy} = sub {
	$button{cursorxy}->{Value} = 0;
	&cursorxyClose;
	&restoreMotionBinding($selectedzinc);
    };
    
    # move mode
    $on_command{move} = sub {
	&saveDragAndDropBindings($selectedzinc);
	$button{move}->{Value} = 1;
	my ($x0, $y0);
	$selectedzinc->Tk::bind('<ButtonPress-1>', sub {
	    my $ev = $selectedzinc->XEvent;
	    ($x0, $y0) = ($ev->x, $ev->y);
	});
	$selectedzinc->Tk::bind('<B1-Motion>', sub {
	    my $ev = $selectedzinc->XEvent;
	    my ($x, $y) = ($ev->x, $ev->y);
	    $selectedzinc->translate(1, $x-$x0, $y-$y0) if defined $x0;
	    ($x0, $y0) = ($x, $y);
	});
    };
    $off_command{move} = sub {
	$button{move}->{Value} = 0;
	&restoreDragAndDropBindings($selectedzinc);
    };
    # zn mode
    $on_command{zn} = sub {
	$button{zn}->{Value} = 1;
	for my $zinc (&instances) {
	    $zinc->remove("zincdebugrectangle", "zincdebuglabel");
	    &saveDragAndDropBindings($zinc);
	    my $r;
	    $zinc->Tk::bind("<ButtonPress-1>", sub {
		$zinc->update;
		my ($w, $h) = ($zinc->cget(-width), $zinc->cget(-height));
		$zinc->tsave(1, 'transfoTopgroup', 1);
		$r = $zinc->add('rectangle', 1, [30, 30, $w-30, $h-30],
				-linecolor => 'red',
				-linewidth => 10);
		$zinc->trestore($r, 'transfoTopgroup');
		$zinc->raise($r);
		$selectedzinc = $zinc;
	    });
	    $zinc->Tk::bind("<ButtonRelease-1>", sub {
		$zinc->remove($r);
	    });
	}
    };
    $off_command{zn} = sub {
	$button{zn}->{Value} = 0;
        for my $zinc (&instances) {
	    &restoreDragAndDropBindings($zinc);
	}
    };

    my @but = qw(findenclosed findoverlap item move zn cursorxy);
    for my $name (@but) {
	$button{$name}->configure(-command => sub {
	    if ($button{$name}->{Value} == 1) {
		for my $other (@but) {
		    &{$off_command{$other}} unless $other eq $name;
		}
	    &{$on_command{$name}};
	    } else {
		&{$off_command{$name}};
	    }});
    }

    $button{id}->configure(-command => sub {
	$button{id}->update;
	&searchentry($zinc);
	$button{id}->toggle;
    });
    
    $button{snapshot}->configure(-command => sub {
	$button{snapshot}->update;
	&printWindow($zinc);
	$button{snapshot}->toggle;
    });
    
    $button{zoomminus}->configure(-command => sub {
	$button{zoomminus}->update;
	my $w = $selectedzinc->cget(-width);
	my $h = $selectedzinc->cget(-height);
	$selectedzinc->translate(1, -$w/2, -$h/2);
	$selectedzinc->scale(1, 1/1.1, 1/1.1);
	$selectedzinc->translate(1, $w/2, $h/2);
	$button{zoomminus}->toggle;
	});
    
    $button{zoomplus}->configure(-command => sub {
	$button{zoomplus}->update;
	my $w = $selectedzinc->cget(-width);
	my $h = $selectedzinc->cget(-height);
	$selectedzinc->translate(1, -$w/2, -$h/2);
	$selectedzinc->scale(1, 1.1, 1.1);
	$selectedzinc->translate(1, $w/2, $h/2);
	$button{zoomplus}->toggle;
	});
        
    $button{tree}->configure(-command => sub {
	$button{tree}->update;
	&showtree($selectedzinc);
	$button{tree}->toggle;
	});
    
    $button{close}->configure(-command => sub {
	$button{close}->update;
	&Tk::Zinc::Debug::iconify;
	&restoreDragAndDropBindings($selectedzinc);
	for my $name (@but) {
	    &{$off_command{$name}};
	}
	$button{close}->toggle;
    });
    
} # end init


#---------------------------------------------------------------------------
#
# Deprecated functions
#
#---------------------------------------------------------------------------

sub tree {
    
    carp "in Tk::Zinc::Debug module, tree() function is deprecated.\n";
    &init($_[0]);
    
} # end tree


sub finditems {
    
    carp "in Tk::Zinc::Debug module, finditems() function is deprecated.\n";
    &init($_[0]);
    
} # end finditems



sub snapshot {
    
    carp "in Tk::Zinc::Debug module, snapshot() function is deprecated.\n";
    &init($_[0]);

} # end snapshot


#---------------------------------------------------------------------------
#
# Functions related to cursor position
#
#---------------------------------------------------------------------------
sub cursorxy {

    my $ev = shift->XEvent;
    $cursorxy = $ev->x.", ".$ev->y;
    
} # end cursorxy


sub cursorxyOpen {

    if (Tk::Exists($cursorxy_tl)) {
	$cursorxy_tl->raise;
	return;
    }
    $cursorxy_tl = $control_tl->Toplevel;
    $cursorxy_tl->Label(-text => "Cursor device position")->pack;
    $cursorxy_tl->Label(-textvariable => \$cursorxy)->pack;
    $cursorxy_tl->minsize(150, 40);
    $cursorxy_tl->raise;
    
} # end cursorxyOpen


sub cursorxyClose {

    $cursorxy_tl->destroy if Tk::Exists($cursorxy_tl);

} # end cursorxyClose


#---------------------------------------------------------------------------
#
# Functions related to items tree
#
#---------------------------------------------------------------------------

# build or rebuild the items tree
sub showtree {
    
    my $zinc = shift;
    my $optionstodisplay = $cmdoptions{optionsToDisplay};
    my $optionsFormat = $cmdoptions{optionsFormat};
    # styles definition
    $itemstyle =
	$zinc->ItemStyle('text', -stylename => "item", -foreground => 'black')
	    unless $itemstyle;
    $groupstyle =
	$zinc->ItemStyle('text', -stylename => "group", -foreground => 'black')
	    unless $groupstyle;

    $WARNING = 0;
    my @optionstodisplay = split(/,/, $optionstodisplay);
    $WARNING = 1;
    &hidetree();
    $tree_tl = $control_tl->Toplevel;
    $tree_tl->minsize(280, 200);
    $tree_tl->title("Zinc Items Tree");
    $tree = $tree_tl->Scrolled('Tree',
			       -scrollbars => 'se',
			       -height => 40,
			       -width => 50,
			       -itemtype => 'text',
			       -selectmode => 'single',
			       -separator => '.',
			       -drawbranch => 1,
			       -indent => 30,
			       -command => sub {
				   my $path = shift;
				   my $item = (split(/\./, $path))[-1];
				   &showresult("Attributes of item $item", $zinc, $item);
				   $zinc->after(100, sub {
				       &undohighlightitem(undef, $zinc)});
			       },
			       );
    &wheelmousebindings($tree);
    $tree->bind('<1>', [sub {
	my $path = $tree->nearest($_[1]);
	my $item = (split(/\./, $path))[-1];
	&highlightitem($tree, $zinc, $item, 0);
		       
    }, Ev('y')]);
    
    $tree->bind('<2>', [sub {
	my $path = $tree->nearest($_[1]);
	return if $path eq 1;
	$tree->selectionClear;
	$tree->selectionSet($path);
	$tree->anchorSet($path);
	my $item = (split(/\./, $path))[-1];
	&highlightitem($tree, $zinc, $item, 1);
		       
    }, Ev('y')]);

    $tree->bind('<3>', [sub {
	my $path = $tree->nearest($_[1]);
	return if $path eq 1;
	$tree->selectionClear;
	$tree->selectionSet($path);
	$tree->anchorSet($path);
	my $item = (split(/\./, $path))[-1];
	&highlightitem($tree, $zinc, $item, 2);
		       
    }, Ev('y')]);
    
    $tree->add("1", -text => "Group(1)", -state => 'disabled');
    &scangroup($zinc, $tree, 1, "1", $optionsFormat, @optionstodisplay);
    $tree->autosetmode;
    # control buttons frame
    my $tree_butt_fm = $tree_tl->Frame(-height => 40)->pack(-side => 'bottom',
							    -fill => 'y');
    $tree_butt_fm->Button(-text => 'Help',
			  -command => [\&showHelpAboutTree, $zinc],
			  )->pack(-side => 'left', -pady => 10,
				  -padx => 10, -fill => 'both');
    
    $tree_butt_fm->Button(-text => 'Search',
			  -command => [\&searchInTree, $zinc],
			  )->pack(-side => 'left', -pady => 10,
				  -padx => 10, -fill => 'both');
    $tree_butt_fm->Button(-text => "Build\ncode",
			  -command => [\&buildCode, $zinc, $tree],
			  )->pack(-side => 'left', -pady => 10,
				  -padx => 10, -fill => 'both');
    
    $tree_butt_fm->Button(-text => "Attributes",
			  -command => sub {
			      my $path = $tree->selectionGet;
			      $path = 1 unless $path;
			      my $item = (split(/\./, $path))[-1];
			      &showresult("Attributes of item $item", $zinc, $item);
			  },
			  )->pack(-side => 'left', -pady => 10,
				  -padx => 10, -fill => 'both');
    

    $tree_butt_fm->Button(-text => 'Close',
			  -command => sub {$zinc->remove("zincdebug");
					   $tree_tl->destroy},
			  )->pack(-side => 'left', -pady => 10,
				  -padx => 20, -fill => 'both');
    # pack tree
    $tree->pack(-padx => 10, -pady => 10,
		-ipadx => 10,
		-side => 'top',
		-fill => 'both',
		-expand => 1,
		);
    

} # end showtree


# destroy the items tree
sub hidetree {
    
    $tree_tl->destroy if $tree_tl and Tk::Exists($tree_tl);
    
} # end hidetree


# find a pointed item in the items tree
sub findintree {
    
    my $zinc = shift;
    if (not Tk::Exists($tree_tl)) {
	&showtree($zinc);
    }
    my $ev = $zinc->XEvent;
    ($x0, $y0) = ($ev->x, $ev->y);
    my @atomicgroups = &unsetAtomicity($zinc);
    my $item = $zinc->find('closest', $x0, $y0);
    &restoreAtomicity($zinc, @atomicgroups);
    return unless $item > 1;
    my @ancestors = reverse($zinc->find('ancestors', $item));
    my $path = join('.', @ancestors).".".$item;
    # tree is rebuilded unless path exists
    unless ($tree->info('exists', $path)) {
	$tree_tl->destroy;
	#print "path=$path rebuild tree\n";
	&showtree($zinc);
    }
    $tree->see($path);
    $tree->selectionClear;
    $tree->anchorSet($path);
    $tree->selectionSet($path);
    &surrounditem($zinc, $item);
    $tree->focus;

} # end findintree


sub searchInTree {
    
    my $zinc = shift;
    $searchtree_tl->destroy if $searchtree_tl and Tk::Exists($searchtree_tl);
    $searchtree_tl = $tree_tl->Toplevel;
    $searchtree_tl->transient($tree_tl);
    $searchtree_tl->title("Find string in tree");
    my $fm = $searchtree_tl->Frame->pack(-side => 'top');
    $fm->Label(-text => "Find : ",
	       )->pack(-side => 'left', -padx => 10, -pady => 10);
    my $entry = $fm->Entry(-width => 20)->pack(-side => 'left',
					       -padx => 10, -pady => 10);
    my $status = $searchtree_tl->Label(-foreground => 'sienna',
				   )->pack(-side => 'top');
    my $ep = 1;
    my $searchfunc =  sub {
	my $side = shift;
	my $found = 0;
        #print "ep=$ep side=$side\n";
	$status->configure(-text => "");
	$status->update;
	$searchTreeEntryValue = $entry->get();
	$searchTreeEntryValue = quotemeta($searchTreeEntryValue);
	my $text;
	while ($ep) {
 	    $ep = $tree->info($side, $ep);
	    unless ($ep) {
		$ep = 1;
		$found = 0;
		last;
	    }
	    $text = $tree->entrycget($ep, -text);
	    if ($text =~ /$searchTreeEntryValue/) {
		$tree->see($ep);
		$tree->selectionClear;
		$tree->anchorSet($ep);
		$tree->selectionSet($ep);
		$found = 1;
		last;
	    }
	}
	#print "searchTreeEntryValue=$searchTreeEntryValue found=$found\n";
	$status->configure(-text => "Search string not found") unless $found > 0;
    };

    my $fm2 = $searchtree_tl->Frame->pack(-side => 'top');
    $fm2->Button(-text => 'Prev',
		 -command => sub {&$searchfunc('prev');},
		 )->pack(-side => 'left', -pady => 10);
    $fm2->Button(-text => 'Next',
		 -command => sub {&$searchfunc('next');},
		 )->pack(-side => 'left', -pady => 10);
    $fm2->Button(-text => 'Close',
		 -command => sub {$searchtree_tl->destroy},
		 )->pack(-side => 'right', -pady => 10);
    $entry->focus;
    $entry->delete(0, 'end');
    $entry->insert(0, $searchTreeEntryValue) if $searchTreeEntryValue;
    $entry->bind('<Key-Return>', sub {&$searchfunc('next');});
    
} # end searchInTree


sub extractinfo {
    my $zinc = shift;
    my $item = shift;
    my $format = shift;
    my $option = shift;
    my $titleflag = shift;
    $option =~ s/^\s+//;
    $option =~ s/\s+$//;
    #print "option=[$option]\n";
    my @info;
    $WARNING = 0;
    eval {@info = $zinc->itemcget($item, $option)};
    #print "eval $option = (@info) $@\n";
    return if $@;
    return if @info == 0;
    my $info;
    my $sep = ($format eq 'column') ? "\n  " : ", ";
    if ($titleflag) {
	$info = $sep."[$option] ".$info[0];
    } else {
	$info = $sep.$info[0];
    }
    if (@info > 1) {
	shift(@info);
	for (@info) {
	    if ($format eq 'column') {
		if (length($info." ".$_) > 40) {
		    if ($titleflag) {
			$info .= $sep."[$option] ".$_;
		    } else {
			$info .= $sep.$_;
		    }
		} else {
		    $info .= ", $_";
		}
	    } else {
		$info .= $sep.$_;
	    }
	}
    }
    $WARNING = 1;
    return $info;
    
} # end extractinfo


sub scangroup {
    
    my ($zinc, $tree, $group, $path, $format, @optionstodisplay) = @_;
    my @items = $zinc->find('withtag', "$group.");
    for my $item (@items) {
	my $Type = ucfirst($zinc->type($item));
	my $info = " ";
	if (@optionstodisplay == 1) {
	    $info .= &extractinfo($zinc, $item, $format, $optionstodisplay[0]);
	} elsif (@optionstodisplay > 1) {
	    for my $opt (@optionstodisplay) {
		$info .= &extractinfo($zinc, $item, $format, $opt, 1);
	    }
	}
	if ($Type eq "Group") {
	    $tree->add($path.".".$item,
		       -text => "$Type($item)$info",
		       -style => 'group',
		       );
	    &scangroup($zinc, $tree, $item, $path.".".$item, $format, @optionstodisplay);
	} else {
	    $tree->add($path.".".$item,
		       -text => "$Type($item)$info",
		       -style => 'item',
		       );
	}
    }

} # end scangroup

#---------------------------------------------------------------------------
#
# Functions used to build code
#
#---------------------------------------------------------------------------

# build perl code corresponding to a branch of the items tree
sub buildCode {
    
    my $zinc = shift;
    my $tree = shift;
    my @code;
    push(@code, 'use Tk;');
    push(@code, 'use Tk::Zinc;');
    push(@code, 'my $mw = MainWindow->new();');
    push(@code, 'my $zinc = $mw->Zinc(-render => '.$zinc->cget(-render).
	 ')->pack(-expand => 1, -fill => "both");');
    push(@code, '# hash %items : keys are original items ID, values are built items ID');
    push(@code, 'my %items;');
    push(@code, '');
    my $path = $tree->selectionGet;
    $path = 1 unless $path;
    my $item = (split(/\./, $path))[-1];
    $endoptions = [];
    if ($zinc->type($item) eq 'group') {
	push(@code, &buildGroup($zinc, $item, 1));
	for(@$endoptions) {
	    my ($item, $option, $value) = @$_;
	    push(@code,
		 '$zinc->itemconfigure('.$item.', '.$option.' => '.$value.');');
	}
    } else {
	push(@code, &buildItem($zinc, $item, 1));
    }
    push(@code, &buildEnd);
    
    my $file = $zinc->getSaveFile(-filetypes => [['Perl Files',   '.pl'],
                                               ['All Files',   '*']],
				  -initialfile => 'zincdebug.pl',
				  -title => 'Save code',
				  );
    return unless defined $file;
    $zinc->Busy;
    open (OUT, ">$file");
    for (@code) {
	print OUT $_."\n";
    }
    close(OUT);
    $zinc->Unbusy;
    
} # end buildCode


sub buildEnd {

    my @code;
    push(@code, 'for (keys(%items)) {');
    push(@code, '   $zinc->addtag(\'orig\'.$_, "withtag", $items{$_});');
    push(@code, '}');
    push(@code, 'MainLoop;');
    return @code
	
} # end buildEnd


# build a node of tree (corresponding to a TkZinc group item)
sub buildGroup {
    
    my $zinc = shift;
    my $item = shift;
    my $group = shift;
    my @code;
    # creation
    push(@code, '$items{'.$item.'}=$zinc->add("group", '.$group.', ');
    # options
    push(@code, &buildOptions($zinc, $item));
    push(@code, ');');
    push(@code, '');
    # coords
    push(@code, '$zinc->coords($items{'.$item.'}, ['.
	 join(',', $zinc->coords($item)).']);');
    # transformations
    push(@code, &buildTransformations($zinc, $item));
    
    my @items = $zinc->find('withtag', "$item.");
    for my $it (reverse(@items)) {
	if ($zinc->type($it) eq 'group') {
	    push(@code, &buildGroup($zinc, $it, '$items{'.$item.'}'));
	} else {
	    push(@code, &buildItem($zinc, $it, '$items{'.$item.'}'));
	}
    }
    return @code;

} # end buildGroup


# build a leaf of tree (corresponding to a TkZinc non-group item)
sub buildItem {
    
    my $zinc = shift;
    my $item = shift;
    my $group = shift;
    my $type = $zinc->type($item);
    my @code;
    my $numfields = 0;
    my $numcontours = 0;
    # creation    
    my $initstring = '$items{'.$item.'}=$zinc->add("'.$type.'", '.$group.', ';
    if ($type eq 'tabular' or $type eq 'track' or $type eq 'waypoint') {
	$numfields = $zinc->itemcget($item, -numfields);
	$initstring .= $numfields.' ,';
    } elsif ($type eq 'curve' or $type eq 'triangles' or
	     $type eq 'arc' or $type eq 'rectangle') {
	$initstring .= "[ ";
	my (@coords) = $zinc->coords($item);
	if (ref($coords[0]) eq 'ARRAY') {
	    my @coords2;
	    for my $c (@coords) {
		if (@$c > 2) {
		     push(@coords2, '['.$c->[0].', '.$c->[1].', "'.$c->[2].'"]');
		} else {
		     push(@coords2, '['.$c->[0].', '.$c->[1].']');
		    
		}
	    }
	    $initstring .= join(', ', @coords2);
	} else {
	    $initstring .= join(', ', @coords);
	}
	$initstring .= " ], ";
	$numcontours = $zinc->contour($item);
    } 
    push(@code, $initstring);
    # options
    push(@code, &buildOptions($zinc, $item));
    push(@code, ');');
    push(@code, '');
    # fields
    if ($numfields > 0) {
    	for (my $i=0; $i < $numfields; $i++) {
	    push(@code, &buildField($zinc, $item, $i));
	}
    }
    # contours
    if ($numcontours > 1) {
	for (my $i=1; $i < $numcontours; $i++) {
	    my (@coords) = $zinc->coords($item);
	    my @coords2;
	    for my $c (@coords) {
		if (@$c > 2) {
		    push(@coords2, '['.$c->[0].', '.$c->[1].', "'.$c->[2].'"]');
		} else {
		    push(@coords2, '['.$c->[0].', '.$c->[1].']');
		}
	    }
	    my $coordstr = '[ '.join(', ', @coords2).' ]';
	    push(@code, '$zinc->contour($items{'.$item.'}, "add", 0, ');
	    push(@code, '            '.$coordstr.');');
	}
    }
    # transformations
    push(@code, &buildTransformations($zinc, $item));
    
    return @code;

} # end buildItem


# add an information field to an item of the tree
sub buildField {
    
    my $zinc = shift;
    my $item = shift;
    my $field = shift;
    my @code;
    # type group and initargs
    push(@code, '$zinc->itemconfigure($items{'.$item.'}, '.$field.', ');
    # options
    push(@code, &buildOptions($zinc, $item, $field));
    push(@code, ');');
    push(@code, '');
    return @code;

} # end buildField


sub buildTransformations {

    my $zinc = shift;
    my $item = shift;
    my @tr = $zinc->tget($item);
    my @code;
    return ('$zinc->tset($items{'.$item.'}, '.join(", ", @tr).');');

} # end buildTransformations


sub buildOptions {
    
    my $zinc = shift;
    my $item = shift;
    my $field = shift;
    my @code;
    my @args = defined($field) ? ($item, $field) : ($item);
    my @options = $zinc->itemconfigure(@args);
    for my $elem (@options) {
	my ($option, $type, $readonly, $value) = (@$elem)[0, 1, 2, 4];
	next if $value eq '';
	next if $readonly;
	if ($type eq 'point') {
	    push(@code, "           ".$option." => [".join(',', @$value)."], ");
	    
	} elsif (($type eq 'bitmap' or $type eq 'image') and $value !~ /^AtcSymbol/
	    and $value !~ /^AlphaStipple/) {
	    push(@code, "#           ".$option." => '".$value."', ");
	    
	} elsif ($type eq 'item') {
	    $endoptions->[@$endoptions] =
		['$items{'.$item.'}', $option, '$items{'.$value.'}'];
	    
	} elsif ($option eq '-text') {
	    $value =~ s/\"/\\"/;       # comment for emacs legibility => "
	    push(@code, "           ".$option.' => "'.$value.'", ');

	} elsif (ref($value) eq 'ARRAY') {
	    push(@code, "           ".$option." => [qw(".join(' ', @$value).")], ");

	} else {
	    push(@code, "           ".$option." => '".$value."', ");
	}
    }
    return @code;

} # end buildOptions

#---------------------------------------------------------------------------
#
# Functions related to search in a rectangular area
#
#---------------------------------------------------------------------------

# begin to draw rectangular area for search
sub startrectangle {
    
    my ($zinc, $style, $text, $color) = @_;
    $zinc->remove("zincdebugrectangle", "zincdebuglabel");
    my $ev = $zinc->XEvent;
    ($x0, $y0) = ($ev->x, $ev->y);
    # store and name the inverted transformation of top group
    $zinc->tsave(1, 'zoom+move', 1);
    $zinc->add('rectangle', 1, [$x0, $y0, $x0, $y0],
	       -linecolor => $color,
	       -linewidth => 2,
	       -linestyle => $style,
	       -tags => ["zincdebugrectangle"],
			       );
    $zinc->add('text', 1,
	       -color => $color,
	       -font => '7x13',
	       -position => [$x0+5, $y0-15],
	       -text => $text,
	       -tags => ["zincdebuglabel"],
	       );
    # apply to new rectangle the (inverted) transformation stored below
    $zinc->trestore("zincdebugrectangle", 'zoom+move');
    $zinc->trestore("zincdebuglabel", 'zoom+move');
  
} # end startrectangle


# resize the rectangular area for search
sub resizerectangle {
    
    my $zinc = shift;
    my $ev = $zinc->XEvent;
    my ($x, $y) = ($ev->x, $ev->y);
    return unless ($zinc->find('withtag', "zincdebugrectangle"));

    $zinc->coords("zincdebugrectangle", 1, 1, [$x, $y]);
    if ($x < $x0) {
	if ($y < $y0) {
	    $zinc->coords("zincdebuglabel", [$x+5, $y-15]);
	} else {
	    $zinc->coords("zincdebuglabel", [$x+5, $y0-15]);
	}
    } else {
	if ($y < $y0) {
	    $zinc->coords("zincdebuglabel", [$x0+5, $y-15]);
	} else {
	    $zinc->coords("zincdebuglabel", [$x0+5, $y0-15]);
	}
    }
    $zinc->raise("zincdebugrectangle");
    $zinc->raise("zincdebuglabel");

} # end resizerectangle


# stop drawing rectangular area for search
sub stoprectangle {
    
    my ($zinc, $searchtype, $text) = @_;
    return unless ($zinc->find('withtag', "zincdebugrectangle"));

    my @atomicgroups = &unsetAtomicity($zinc);
    $zinc->update;
    my ($c0, $c1) = $zinc->coords("zincdebugrectangle");
    my @coords = (@$c0, @$c1);
    my @items;
    for my $item ($zinc->find($searchtype, @coords, 1, 1)) {
	push (@items, $item) unless $zinc->hastag($item, "zincdebugrectangle") or
	    $zinc->hastag($item, "zincdebuglabel");
    }
    &restoreAtomicity($zinc, @atomicgroups);
    if (@items) {
	&showresult($text, $zinc, @items);
    } else {
	$zinc->remove("zincdebugrectangle", "zincdebuglabel");
    }

} # end stoprectangle


# in order to avoid find problems with group atomicity, we set all -atomic
# attributes to 0
sub unsetAtomicity {
    
    my $zinc = shift;
    my @groups = $zinc->find('withtype', 'group');
    my @atomicgroups;
    for my $group (@groups) {
	if ($zinc->itemcget($group, -atomic)) {
	    push(@atomicgroups, $group);
	    $zinc->itemconfigure($group, -atomic => 0);
	}
    }
    return @atomicgroups;
    
} # end unsetAtomicity


sub restoreAtomicity {
    
    my $zinc = shift;
    my @atomicgroups = @_;
    for my $group (@atomicgroups) {
	$zinc->itemconfigure($group, -atomic => 1);
    }

} # end restoreAtomicity


#---------------------------------------------------------------------------
#
# Function related to item's id search 
#
#---------------------------------------------------------------------------

sub searchentry {
    
    my $zinc = shift;
    $search_tl->destroy if $search_tl and Tk::Exists($search_tl);
    $search_tl = $control_tl->Toplevel;
    $search_tl->title("Specific search");
    my $fm = $search_tl->Frame->pack(-side => 'top');
    $fm->Label(-text => "Item TagOrId : ",
	       )->pack(-side => 'left', -padx => 10, -pady => 10);
    my $entry = $fm->Entry(-width => 20)->pack(-side => 'left',
					       -padx => 10, -pady => 10);
    my $status = $search_tl->Label(-foreground => 'sienna',
				   )->pack(-side => 'top');
    $search_tl->Button(-text => 'Close',
		       -command => sub {$search_tl->destroy},
		       )->pack(-side => 'top', -pady => 10);
    $entry->focus;
    $entry->delete(0, 'end');
    $entry->insert(0, $searchEntryValue{$zinc}) if $searchEntryValue{$zinc};
    $entry->bind('<Key-Return>', [sub {
	$status->configure(-text => "");
	$status->update;
	$searchEntryValue{$zinc} = $entry->get();
	my @items = $zinc->find('withtag', $searchEntryValue{$zinc});
	if (@items) {
	    my $label;
	    if ($searchEntryValue{$zinc} =~ /^\d/) {
		$label = "Attributes of item $searchEntryValue{$zinc}";
	    } else {
		$label = "Attributes of item(s) with tag $searchEntryValue{$zinc}"
	    }
	    &showresult($label, $zinc, @items);
	} else {
	    $status->configure(-text => "No such tagOrId ($searchEntryValue{$zinc})");
	}
    }]);
    
} # end searchentry


#---------------------------------------------------------------------------
#
# Functions related to transformations parameters
#
#---------------------------------------------------------------------------

sub showtransfoparams {

    my ($label, $zinc, $item) = @_;
    my @m = $zinc->tget($item);
    my ($m00, $m01, $m10, $m11, $m20, $m21) = @m;
    my ($xt, $yt, $xsc, $ysc, $a, $xsk, $ysk) = $zinc->tget($item, 'all');
    # bug zinc 
    $ysk = 0 unless defined $ysk;
    for ($m00, $m01, $m10, $m11, $m20, $m21, $xt, $yt, $xsc, $ysc, $a, $xsk, $ysk) {
	$_ = sprintf("%.2f", $_) if /^-?\d+\.\d/;
    }
    $transfo_tl{$item}->destroy if Tk::Exists($transfo_tl{$item});
    $transfo_tl{$item} = $control_tl->Toplevel();
    $transfo_tl{$item}->transient($result_tl{$label})
	if Tk::Exists($result_tl{$label});
    my $title = "Transformations of item $item";
    $transfo_tl{$item}->title($title);
    my $bgcolor = 'ivory';
    my $fm1 = $transfo_tl{$item}->Frame()->pack(-side => 'top',
						-padx => 20,
						-pady => 10,
						-expand => 1,
						-fill => 'x',
						);
    # set transformation to ident
    my $btn = $fm1->Button(-text => "Show item with transformation\nset to identity",
			   -bg => $bgcolor,
			   )->pack(-side => 'top', -padx => 5, -pady => 10);
    $balloonhelp->attach($btn,-balloonmsg =>
			 "Click and maintain to show the transformation  \n".
			 "animation. Use btn1, btn2 or btn3 to select the\n".
			 "best background color for a good visibility.   ");
    $btn->bind('<1>', [\&showtransfo, $zinc, $item, 0]);
    $btn->bind('<2>', [\&showtransfo, $zinc, $item, 1]);
    $btn->bind('<3>', [\&showtransfo, $zinc, $item, 2]);
    
    my $fm11 = $fm1->Frame()->pack(-side => 'left',
				   -padx => 20,
				   );

    my ($set_cb, $reset_cb, $upd_cb);
    
    # matrix
    my $r = 0;
    my $c = 0;
    $fm11->Label(-text => 'matrix', -relief => 'ridge', -bg => $bgcolor)
	->grid(-row => $r++, -columnspan => 2,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    $fm11->Label(-textvariable => \$m00, -relief => 'ridge')
	->grid(-row => $r, -column => $c,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    $fm11->Label(-textvariable => \$m01, -relief => 'ridge')
	->grid(-row => $r++, -column => $c+1,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    $fm11->Label(-textvariable => \$m10, -relief => 'ridge')
	->grid(-row => $r, -column => $c,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    $fm11->Label(-textvariable => \$m11, -relief => 'ridge')
	->grid(-row => $r++, -column => $c+1,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    $fm11->Label(-textvariable => \$m20, -relief => 'ridge')
	->grid(-row => $r, -column => $c,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    $fm11->Label(-textvariable => \$m21, -relief => 'ridge')
	->grid(-row => $r++, -column => $c+1,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    


    my $fm12 = $fm1->Frame()->pack(-side => 'left',
				   -padx => 20,
				   );
    my ($e_xt, $e_yt, $e_xsc, $e_ysc, $e_a, $e_xsk, $e_ysk);

    $set_cb = sub {
	$zinc->treset($item);
	$zinc->translate($item, $e_xt, $e_yt);
	$zinc->rotate($item, $e_a);
	$zinc->scale($item, $e_xsc, $e_ysc);
	$zinc->skew($item, $e_xsk, $e_ysk);
	($m00, $m01, $m10, $m11, $m20, $m21) = $zinc->tget($item);
	for ($m00, $m01, $m10, $m11, $m20, $m21) {
	    $_ = sprintf("%.2f", $_) if /^-?\d+\.\d/;
	}
    };

    # translate params
    $r = 0;
    $c = 0;    
    $fm12->Label(-text => 'translate', -relief => 'ridge', -bg => $bgcolor)
	->grid(-row => $r, -column => $c++,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');

    &entrytransfo($fm12, $item, $zinc, 'xt', $xt, \$e_xt, 4, $set_cb)
    	->grid(-row => $r, -column => $c++,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    
    &entrytransfo($fm12, $item, $zinc, 'yt', $yt, \$e_yt, 4, $set_cb)
	->grid(-row => $r++, -column => $c++,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    
    # rotate params
    $c = 0;
    $fm12->Label(-text => 'rotate', -relief => 'ridge', -bg => $bgcolor)
	->grid(-row => $r, -column => $c++,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');

    &entrytransfo($fm12, $item, $zinc, 'a', $a, \$e_a, 4, $set_cb)
	->grid(-row => $r++, -column => $c++,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');

    # scale params
    $c = 0;
    $fm12->Label(-text => 'scale', -relief => 'ridge', -bg => $bgcolor)
	->grid(-row => $r, -column => $c++,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');

    &entrytransfo($fm12, $item, $zinc, 'xsc', $xsc, \$e_xsc, 4, $set_cb)
	->grid(-row => $r, -column => $c++,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    &entrytransfo($fm12, $item, $zinc, 'ysc', $ysc, \$e_ysc, 4, $set_cb)
	->grid(-row => $r++, -column => $c++,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    
    # skew params
    $c = 0;
    $fm12->Label(-text => 'skew', -relief => 'ridge', -bg => $bgcolor)
	->grid(-row => $r, -column => $c++,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    
    &entrytransfo($fm12, $item, $zinc, 'xsk', $xsk, \$e_xsk, 4, $set_cb)
	->grid(-row => $r, -column => $c++,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    &entrytransfo($fm12, $item, $zinc, 'ysk', $ysk, \$e_ysk, 4, $set_cb)
	->grid(-row => $r++, -column => $c++,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');


    my $fm2 = $transfo_tl{$item}->Frame()->pack(-side => 'top',
						-padx => 20,
						-pady => 0,
						);
    $fm2->Button(-text => 'Close',
		-command => sub {
		    $transfo_tl{$item}->destroy;
		    delete $transfo_tl{$item};
		})->pack(-side => 'top', -padx => 40, -pady => 20);
    
    
    
} # end showtransfoparams


#---------------------------------------------------------------------------
#
# Functions related to results tables display
#
#---------------------------------------------------------------------------

# display in a toplevel the result of search ; a new toplevel destroyes the
# previous one
sub showresult {
    
    my ($label, $zinc, @items) = @_;
    # toplevel (re-)creation
    $result_tl{$label}->destroy if Tk::Exists($result_tl{$label});
    $result_tl{$label} = $control_tl->Toplevel();
    my $title = "TK::Zinc Debug";
    $title .= " - $label" if $label;
    $result_tl{$label}->title($title);
    $result_tl{$label}->geometry('+10+20');
    $control_tl->raise;
    my $fm = $result_tl{$label}->Frame()->pack(-side => 'bottom',
				       );
    $fm->Button(-text => 'Close',
		-command => sub {
		    $result_tl{$label}->destroy;
		    delete $result_tl{$label};
		    $zinc->remove("zincdebugrectangle", "zincdebuglabel");
		})->pack(-side => 'left', -padx => 40, -pady => 10);
    
    # scrolled pane creation
    $result_fm = $result_tl{$label}->Scrolled('Pane',
					      -scrollbars => 'osoe',
					      -height => 200,
					      -width => 1024,
					      );
    &wheelmousebindings($result_fm);
    my $fm2 = $result_fm->Frame->pack;
    # attributes display
    &showattributes($zinc, $fm2, $label, \@items);
    $result_fm->update;
    $fm2->update;
    my $width = $fm2->width + 10;
    $width = $screenwidth if $width > $screenwidth;
    $result_fm->configure(-width => $width);
    $result_fm->pack(-padx => 10, -pady => 10,
		     -ipadx => 10,
		     -fill => 'both',
		     -expand => 1,
		     );

} # end showresult

# display table containing additionnal options/values
sub showalloptions {
    
    my ($label, $zinc, $item, $fmp) = @_;
    $alloptions_tl{$item}->destroy if Tk::Exists($alloptions_tl{$item});
    $alloptions_tl{$item} = $control_tl->Toplevel();
    $alloptions_tl{$item}->transient($result_tl{$label})
	if Tk::Exists($result_tl{$label});
    my $tl = $alloptions_tl{$item};
    my $title = "All options of item $item";
    $tl->title($title);
    $tl->geometry('-10+0');
    

    # footer
    #----------------
    $tl->Button(-text => 'Close',
		-command => sub {
		    $alloptions_tl{$item}->destroy;
		    delete $alloptions_tl{$item};
		})->pack(-side => 'bottom');
    # option scrolled frame
    #-----------------------
    my $fm = $tl->Scrolled('Pane',
			   -scrollbars => 'oe',
			   -height => 500,
			   )->pack(-padx => 10, -pady => 10,
				   -ipadx => 10,
				   -expand => 1,
				   -fill => 'both');
    
    my $bgcolor = 'ivory';
    my $i = 1;
    $fm->Label(-text => $title, -background => $bgcolor,
	       -fg => 'sienna', -relief => 'ridge')
	->grid(-row => $i++, -column => 1, -ipady => 5, -ipadx => 5,
	       -columnspan => 2, -sticky => 'nswe') if $label;
    $fm->Label(-text => 'Option', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Value', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i++, -column => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe');

    my @options = $zinc->itemconfigure($item);
    for my $elem (@options) {
	my ($option, $type, $value) = (@$elem)[0,1,4];
	$fm->Label(-text => $option, -relief => 'ridge')
	    ->grid(-row => $i, -column => 1,
		   -ipady => 5, -ipadx => 5, -sticky => 'nswe');
	if ($option eq '-tags') {
	    &entryoption($fm, $item, $zinc, $option,
			 join("\n", @$value), 30, 30, scalar @$value)
		->grid(-row => $i, -column => 2, -ipady => 5,
		       -ipadx => 5, -sticky => 'nswe');
	} else {
	    &entryoption($fm, $item, $zinc, $option, undef, 50, 25)
		->grid(-row => $i, -column => 2, -ipady => 5,
		       -ipadx => 5, -sticky => 'nswe');
	}
	$i++;
    }
    
} # end showalloptions


# display device coords table
sub showdevicecoords {
    
    my ($label, $zinc, $item) = @_;
    &showcoords($label, $zinc, $item, 1);

} # end showdevicecoords


# display coords table
sub showcoords {
    
    my ($label, $zinc, $item, $deviceflag) = @_;
    my $bgcolor = 'ivory';
    my $bgcolor2 = 'gray75';
    $coords_tl{$item}->destroy if Tk::Exists($coords_tl{$item}) and not $deviceflag;
    $coords_tl{$item} = $control_tl->Toplevel();
    $coords_tl{$item}->transient($result_tl{$label}) if Tk::Exists($result_tl{$label});
    my $title = "Zinc Debug";
    if ($deviceflag) {
	$title .= " - Coords of item $item";
    } else {
	$title .= " - Device coords of item $item";
    }
    $coords_tl{$item}->title($title);
    $coords_tl{$item}->geometry('+10+20');
    my $coords_fm0 = $coords_tl{$item}->Frame()->pack(-side => 'bottom');
    $coords_fm0->Button(-text => 'Help',
			-command => [\&showHelpAboutCoords, $zinc]
			)->pack(-side => 'left', -padx => 40, -pady => 10);
    $coords_fm0->Button(-text => 'Close',
			-command => sub {
			    &hidecontour($zinc);
			    $coords_tl{$item}->destroy;
			    delete $coords_tl{$item};
			})->pack(-side => 'left', -padx => 40, -pady => 10);
    # scrolled pane creation
    my $coords_fm = $coords_tl{$item}->Scrolled('Pane',
					 -scrollbars => 'oe',
					 -height => 200,
					 )->pack(-padx => 10, -pady => 10,
						 -ipadx => 10,
						 -expand => 1,
						 -fill => 'both');
    my @contour;
    my $contournum = $zinc->contour($item);
    for (my $i=0; $i < $contournum; $i++) {
	my @coords = $zinc->coords($item, $i);
	if (!ref $coords[0]) {
	    ## The first item of the list is not a reference, so the
	    ## list is guarranted to be a flat list (x, y, ...)
	    ## normaly of only one pair of (x y)
	    @coords = $zinc->transform($item, 'device', [@coords])
		if $deviceflag;
	    for (my $j=0; $j < @coords; $j += 2) {
		push(@{$contour[$i]}, [$coords[$j], $coords[$j+1]]);
	    }
	}
	else {
	    ## the first element is an array reference, as every
	    ## other elements of the list
	    for (my $j=0; $j < @coords; $j ++) {
		my @c = @{$coords[$j]};
		@c = $zinc->transform($item, 'device', [@c])
		    if $deviceflag;
		push(@{$contour[$i]}, [@c]);
	    }
	}
    }
    my $row = 1;
    my $col = 1;
    for (my $i=0; $i < @contour; $i++) {
	$col = 1;
	my $lab = $coords_fm->Label(-text => "Contour $i",
				    -background => $bgcolor,
				    -relief => 'ridge')->grid(-row => $row,
							      -column => $col,
							      -ipadx => 5,
							      -ipady => 5,
							      -sticky => 'nswe');
	$lab->bind('<1>', [\&showcontour, $zinc, 'black', $item, $contour[$i],
			   $deviceflag]);
	$lab->bind('<2>', [\&showcontour, $zinc, 'white', $item, $contour[$i],
			   $deviceflag]);
	$lab->bind('<3>', [\&showcontour, $zinc, 'red', $item, $contour[$i],
			   $deviceflag]);
	$lab->bind('<ButtonRelease-1>', sub { &hidecontour($zinc); });
	$lab->bind('<ButtonRelease-2>', sub { &hidecontour($zinc); });
	$lab->bind('<ButtonRelease-3>', sub { &hidecontour($zinc); });
	my $lab1 = $coords_fm->Label(-text => scalar(@{$contour[$i]})." points",
				     -background => $bgcolor,
				     -relief => 'ridge')->grid(-row => $row+1,
							       -column => $col,
							       -ipadx => 5,
							       -ipady => 5,
							       -sticky => 'nswe');
	$lab1->bind('<1>', [\&showcontourpts, $zinc, 'black', $item, $contour[$i],
			    $deviceflag]);
	$lab1->bind('<2>', [\&showcontourpts, $zinc, 'white', $item, $contour[$i],
			    $deviceflag]);
	$lab1->bind('<3>', [\&showcontourpts, $zinc, 'red', $item, $contour[$i],
			    $deviceflag]);
	$lab1->bind('<ButtonRelease-1>', sub { &hidecontour($zinc); });
	$lab1->bind('<ButtonRelease-2>', sub { &hidecontour($zinc); });
	$lab1->bind('<ButtonRelease-3>', sub { &hidecontour($zinc); });
	$col++;
	my @lab;
	for my $coords (@{$contour[$i]}) {
	    if ($col > 10) {
		$col = 2;
		$row++;
	    }
	    $coords->[0] =~ s/\.(\d\d).*/\.$1/;
	    $coords->[1] =~ s/\.(\d\d).*/\.$1/;
	    my @opt;
	    if (defined $coords->[2]) {
		@opt = (-text => sprintf('%s, %s, %s', @$coords),
			-underline => length(join(',', @$coords)) + 1,
			);
	    } else {
		@opt = (-text => sprintf('%s, %s', @{$coords}[0,1]));
	    }
	    push (@lab, $coords_fm->Label(@opt,
					  -width => 15,
					  -relief => 'ridge')->grid(-row => $row,
								    -ipadx => 5,
								    -ipady => 5,
								    -column => $col++,
								    -sticky => 'nswe'));
	}
	$row++ if (@{$contour[$i]} < 10);
	$row++;
	my $j = 0;
	for (@lab) {
	    $_->bind('<1>', [\&showcontourpt, $zinc, 'black',
			     $item, $j, $deviceflag, \@lab, @{$contour[$i]}]);
	    $_->bind('<2>', [\&showcontourpt, $zinc, 'white',
			     $item, $j, $deviceflag, \@lab, @{$contour[$i]}]);
	    $_->bind('<3>', [\&showcontourpt, $zinc, 'red',
			     $item, $j, $deviceflag, \@lab, @{$contour[$i]}]);
	    $j++;
	}

    }

} # end showcoords



# display in a grid the values of most important attributes 
sub showattributes {
    
    my ($zinc, $fm, $label, $items, $expandTagsFlag) = @_;
    $expandTagsFlag = 1;
    &getsize($zinc);
    my $bgcolor = 'ivory';
    my $i = 1;
    $fm->Label(-text => $label, -background => $bgcolor,
	       -fg => 'sienna', -relief => 'ridge')
	->grid(-row => $i++, -column => 0, -ipady => 0, -ipadx => 5,
	       -columnspan => 7, -sticky => 'nswe') if $label;

    &showbanner($fm, $i++);
    $i++;
    for my $item (@$items) {
	my $c = 0;
	my $type = $zinc->type($item);
	# id
	my $idbtn =
	    $fm->Button(-text => $item,
			-foreground => 'sienna'
			)->grid(-row => $i, -column => $c++, -sticky => 'nswe',
				-ipadx => 5);
	$idbtn->bind('<1>', [\&highlightitem, $zinc, $item, 0]);
	$idbtn->bind('<2>', [\&highlightitem, $zinc, $item, 1]);
	$idbtn->bind('<3>', [\&highlightitem, $zinc, $item, 2]);
	$balloonhelp->attach($idbtn,-balloonmsg =>
			     "Click and maintain to show the item.     \n".
			     "Use btn1, btn2 or btn3 to select the best\n".
			     "background color for a good visibility.  ");
	# type
	if ($type eq 'group') {
	    my $gbtn =
		$fm->Button(-text => $type,
			    -command => sub {
				my @items = $zinc->find('withtag', $item.".");
				&showresult("Content of group $item", $zinc, @items);
			    });
	    $gbtn->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5);
	    $balloonhelp->attach($gbtn,-balloonmsg =>
				 "Click to display the group's content.");
	} else {
	    $fm->Label(-text => $type, -relief => 'ridge')
		->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5);
	}
	# parent group
	my $group = $zinc->group($item);
	my $pgbtn =
	    $fm->Button(-text => $group,
			-command => [\&showresult,
				     "Attributes of group $group (parent of $item)",
				     $zinc, $group]);
	$pgbtn->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5);
	$balloonhelp->attach($pgbtn,-balloonmsg =>
			     "Click to display the parent group's attributes.");
	# priority
	&entryoption($fm, $item, $zinc, -priority)
	    ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 2);
	# sensitiveness
	&entryoption($fm, $item, $zinc, -sensitive)
	    ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 2);
	# visibility
	&entryoption($fm, $item, $zinc, -visible)
	    ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 2);
	# other options
	$fm->Button(-text => 'show',
		    -command => [\&showalloptions, $label, $zinc, $item, $fm])
	    ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5);
	# transformations
	my $tlabel = 'yes';
	my ($xt, $yt, $xsc, $ysc, $a, $xsk) = $zinc->tget($item, 'all');
	$tlabel = 'no' if ($xt == 0 and $yt == 0 and $xsc == 1 and $ysc == 1 and
			   $a == 0 and $xsk == 0);
	my $tbtn =
	    $fm->Button(-text => $tlabel, 
			-command => [\&showtransfoparams, $label, $zinc, $item],
			);
	$tbtn->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5);
	$balloonhelp->attach($tbtn,-balloonmsg =>
			     "Click to display transformation parameters.\n".
			     "Some of them can be updated.               ");
	
	# coords
	my @coords = $zinc->coords($item);
	my $coords;
	if (!ref $coords[0]) {
	    my $x0 = int($coords[0]);
	    my $y0 = int($coords[1]);
	    $coords = "($x0, $y0)";
	} else {
	    my @points0 = @{$coords[0]};
	    my $n = $#coords;
	    my @pointsN = @{$coords[$n]};
	    my $x0 = int($points0[0]);
	    my $y0 = int($points0[1]);
	    my $xn = int($pointsN[0]);
	    my $yn = int($pointsN[1]);
	    if ($n == 1) { ## a couple of points
		$coords = "($x0, $y0, $xn, $yn)";
	    } else {
		$coords = "P0=($x0, $y0), ..., P".$n."=($xn, $yn)";
	    }
	}
	if (@coords > 2) {
	    my $cbtn = $fm->Button(-text => $coords,
				   -command => [\&showcoords, $label, $zinc, $item]);
	    $cbtn->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 2);
	    $balloonhelp->attach($cbtn,-balloonmsg =>
				 "Click to show all coordinates.");
	} else {
	    $fm->Label(-text => $coords, -relief => 'ridge')
		->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5);
	}
	# device coords
	@coords = $zinc->transform($item, 'device', [@coords]);
	if (!ref $coords[0]) {
	    my $x0 = int($coords[0]);
	    my $y0 = int($coords[1]);
	    $coords = "($x0, $y0)";
	} else {
	    my @points0 = @{$coords[0]};
	    my $n = $#coords;
	    my @pointsN = @{$coords[$n]};
	    my $x0 = int($points0[0]);
	    my $y0 = int($points0[1]);
	    my $xn = int($pointsN[0]);
	    my $yn = int($pointsN[1]);
	    if ($n == 1) { ## a couple of points
		$coords = "($x0, $y0, $xn, $yn)";
	    } else {
		$coords = "P0=($x0, $y0), ..., P".$n."=($xn, $yn)";
	    }
	}
	if (@coords > 2) {
	    my $dcbtn =
		$fm->Button(-text => $coords,
			    -command => [\&showdevicecoords, $label, $zinc, $item]);
	    $dcbtn->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 2);
	    $balloonhelp->attach($dcbtn,-balloonmsg =>
				 "Click to show all device coordinates.");
	} else {
	    $fm->Label(-text => $coords, -relief => 'ridge')
		->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5);
	}
	# bounding box
	my @bbox = $zinc->bbox($item);
	if (@bbox == 4) {
	    my ($b0, $b1, $b2, $b3) = @bbox;
	    $b0 = sprintf("%.2f", $b0) if int($b0) ne $b0;
	    $b1 = sprintf("%.2f", $b1) if int($b1) ne $b1;
	    $b2 = sprintf("%.2f", $b2) if int($b2) ne $b2;
	    $b3 = sprintf("%.2f", $b3) if int($b3) ne $b3;
	    my $btn = $fm->Button(-text => "($b0, $b1), ($b2, $b3)")
		->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5);
	    $btn->bind('<1>', [\&showbbox, $zinc, $item]);
	    $btn->bind('<ButtonRelease-1>', [\&hidebbox, $zinc]) ;
	    $balloonhelp->attach($btn,-balloonmsg =>
				 "Click to show the bounding box.");
	} else {
	    $fm->Label(-text => "--", , -relief => 'ridge')
		->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5);
	}
	# tags
  	my @tags = $zinc->gettags($item);
	my $height = 2;
	$height = scalar @tags if $cmdoptions{expandTagsField};
	&entryoption($fm, $item, $zinc, -tags, join("\n", @tags), 30, 30, $height)
	    ->grid(-row => $i, -column => $c++, -sticky => 'nswe', -ipadx => 5);

	$i++;
	&showbanner($fm, $i++) if ($i % 15 == 0);
    }
    
} # end showattributes


sub showbanner {
    
    my $fm = shift;
    my $i = shift;
    my $bgcolor = 'ivory';
    my $c = 0;
    $fm->Label(-text => "Item\nId", -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => $c++, -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => "Item\nType", -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => $c++, -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => "Parent\ngroup", -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => $c++, -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => "P\nr\ni\no", -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => $c++, -ipady => 2, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => "S\ne\nn\ns", -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => $c++, -ipady => 2, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => "V\ni\ns\ni", -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => $c++, -ipady => 2, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => "All\noptions", -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => $c++,
	       -ipady => 5, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => "Transfo", -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => $c++,
	       -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Coords', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => $c++,
	       -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Device coords', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => $c++,
	       -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Bounding box', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => $c++,
	       -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label(-text => 'Tags', -background => $bgcolor, -relief => 'ridge')
	->grid(-row => $i, -column => $c++,
	       -ipady => 10, -ipadx => 5, -sticky => 'nswe');
    $fm->Label()->grid(-row => 1, -column => $c++, -pady => 10);

} # end showbanner


#---------------------------------------------------------------------------
#
# Functions related to contours display
#
#---------------------------------------------------------------------------

# display contour (as simple curve)
sub showcontour {
    my ($widget, $zinc, $color, $item, $contourcoords, $deviceflag) = @_;
    if ($deviceflag) {
	$zinc->add('curve', 1, $contourcoords,
		   -filled => 0,
		   -linecolor => $color,
		   -tags => ['zincdebugcontour']);

    } else {
	$zinc->add('curve', 1, [$zinc->transform($item, 1, $contourcoords)],
		   -filled => 0,
		   -linecolor => $color,
		   -tags => ['zincdebugcontour']);
    }
    $zinc->raise('zincdebugcontour');
    
} # end showcontour


sub hidecontour {
    
    my ($zinc) = @_;
    $zinc->remove('zincdebugcontour');
    
} # end hidecontour


# display contours points (one rectangle per point)
sub showcontourpts {
    my ($widget, $zinc, $color, $item, $contourcoords, $deviceflag) = @_;
    my $i = 0;
    for my $coords (@$contourcoords) {
	my ($x, $y);
	if ($deviceflag) {
	    ($x, $y) = @$coords;
	} else {
	    ($x, $y) = $zinc->transform($item, 1, $coords);
	}
	if ($i == 0) {
	    $zinc->add('arc', 1, [$x-10, $y-10, $x+10, $y+10],
		       -filled => 0,
		       -linewidth => 1,
		       -linecolor => $color,
		       -tags => ['zincdebugcontour']);
	} elsif ($i == @$contourcoords -1) {
	    $zinc->add('arc', 1, [$x-10, $y-10, $x+10, $y+10],
		       -filled => 0,
		       -linewidth => 1,
		       -linecolor => $color,
		       -tags => ['zincdebugcontour']);
	    $zinc->add('arc', 1, [$x-13, $y-13, $x+13, $y+13],
		       -filled => 0,
		       -linewidth => 1,
		       -linecolor => $color,
		       -tags => ['zincdebugcontour']);
	}
	my $dx = 3;
	if (@$coords > 2) {
	    $zinc->add('rectangle', 1, [$x-$dx, $y-$dx, $x+$dx, $y+$dx],
		       -filled => 0,
		       -linewidth => 1,
		       -linecolor => $color,
		       -tags => ['zincdebugcontour']);
	} else {
	    $zinc->add('rectangle', 1, [$x-$dx, $y-$dx, $x+$dx, $y+$dx],
		       -filled => 1,
		       -linewidth => 1,
		       -fillcolor => $color,
		       -linecolor => $color,
		       -tags => ['zincdebugcontour']);
	}
	$i++;
    }
    $zinc->raise('zincdebugcontour');
    
} # end showcontourpts


# display one point of a contour (as a rectangle)
sub showcontourpt {
    
    my ($widget, $zinc, $color, $item, $index, $deviceflag, $labels, @contour) = @_;
    $widget->focus;
    if ($index < 0 or $index >= @contour) {
	$widget->bell;
	return;
    }
    &hidecontour($zinc);
    my $bgcolor = ($labels->[0]->configure(-background))[3];
    for (@$labels) {
	$_->configure(-background => $bgcolor);
    }
    $labels->[$index]->configure(-background => 'bisque');
    my @coords = @{$contour[$index]};
    my ($x, $y);
    if ($deviceflag) {
	($x, $y) = @coords;
    } else {
	($x, $y) = $zinc->transform($item, 1, [@coords]);
    }
    my $dx = 3;
    if (@coords > 2) {
	$zinc->add('rectangle', 1, [$x-$dx, $y-$dx, $x+$dx, $y+$dx],
		   -filled => 0,
		   -linewidth => 1,
		   -linecolor => $color,
		   -tags => ['zincdebugcontour']);
    } else {
	$zinc->add('rectangle', 1, [$x-$dx, $y-$dx, $x+$dx, $y+$dx],
		   -filled => 1,
		   -linewidth => 1,
		   -fillcolor => $color,
		   -linecolor => $color,
		   -tags => ['zincdebugcontour']);
    }
    $widget->bind('<Key-Down>', [\&showcontourpt, $zinc, $color,
				 $item, $index+1, $deviceflag, $labels, @contour]);
    $widget->bind('<Key-Right>', [\&showcontourpt, $zinc, $color,
				 $item, $index+1, $deviceflag, $labels, @contour]);
    $widget->bind('<Key-Up>', [\&showcontourpt, $zinc, $color,
				$item, $index-1, $deviceflag, $labels, @contour]);
    $widget->bind('<Key-Left>', [\&showcontourpt, $zinc, $color,
				$item, $index-1, $deviceflag, $labels, @contour]);
    $zinc->raise('zincdebugcontour');

} # end showcontourpt


#---------------------------------------------------------------------------
#
# Functions related to items graphical presentation
#
#---------------------------------------------------------------------------

# display the bbox of a group item
sub showbbox {
    
    my ($btn, $zinc, $item) = @_;
    $zinc->tsave(1, 'zoom+move', 1);
    my @bbox  = $zinc->bbox($item);
    if (scalar @bbox == 4) {
	# If item is visible, rectangle is drawm surround it.
	# Else, a warning is displayed.
	unless (&itemisoutside($zinc, @bbox)) {
	    my $i = -2;
	    for ('white', 'blue', 'white') {
		$zinc->add('rectangle', 1,
			   [$bbox[0] + $i, $bbox[1] + $i,
			    $bbox[2] - $i, $bbox[3] - $i],
			   -linecolor => $_,
			   -linewidth => 1,
			   -tags => ['zincdebugbbox']);
		$i += 2;
	    }
	}
    }
    $zinc->trestore('zincdebugbbox', 'zoom+move');
    $zinc->raise('zincdebugbbox');

} # end showbbox


sub hidebbox {
    
    my ($btn, $zinc) = @_;
    $zinc->remove("zincdebugbbox");

} # end hidebbox


# display a message box when an item is not visible because outside window
sub itemisoutside {
    
    my $zinc = shift;
    my @bbox = @_;
    return unless @bbox == 4;
    &getsize($zinc);
    #print "bbox=(@bbox) wheight=$wheight{$zinc} wwidth=$wwidth{$zinc}\n";
    my $outflag;
    $WARNING = 0;
    if ($bbox[2] < 0) {
	if ($bbox[1] >  $wheight{$zinc}) {
	    $outflag = 'left+bottom';
	} elsif ($bbox[3] < 0) {
	    $outflag = 'left+top';
	} else {
	    $outflag = 'left';
	} 
    } elsif ($bbox[0] > $wwidth{$zinc}) {
	if ($bbox[1] >  $wheight{$zinc}) {
	    $outflag = 'right+bottom';
	} elsif ($bbox[3] < 0) {
	    $outflag = 'right+top';
	} else {
	    $outflag = 'right';
	}
    } elsif ($bbox[3] < 0) {
	$outflag = 'top';
    } elsif ($bbox[1] > $wheight{$zinc}) {
	$outflag = 'bottom';
    }
    #print "outflag=$outflag bbox=@bbox\n";
    return 0 unless $outflag;
    # create first group which will be translated. We will apply to this group
    # the reverse transformation of topgroup. 
    my $g = $zinc->add('group', 1, -tags => ['zincdebug']);
    # create child group which won't be affected by ancestor's scale.
    my $g1 = $zinc->add('group', $g, -composescale => 0);
    my $hw = 110;
    my $hh = 80;
    my $r = 5;
    $zinc->add('rectangle', $g1, [-$hw, -$hh, $hw, $hh],
	       -filled => 1,
	       -linecolor => 'sienna',
	       -linewidth => 3,
	       -fillcolor => 'bisque',
	       -priority => 1,
	       );
    $zinc->add('text', $g1,
	       -position => [0, 0],
	       -color => 'sienna',
	       -font => '-b&h-lucida-bold-i-normal-sans-34-240-*-*-p-*-iso8859-1',
	       -anchor => 'center',
	       -priority => 2,
	       -text => "Item is\noutside\nwindow\n");
    my ($x, $y);
    if ($outflag eq 'bottom') {
	$x = $bbox[0] + ($bbox[2]-$bbox[0])/2;
	$x = $hw + 10 if $x < $hw + 10;
	$x = $wwidth{$zinc} - $hw - 10 if $x > $wwidth{$zinc} - $hw - 10;
	$y = $wheight{$zinc} - $hh - 10;
    } elsif ($outflag eq 'top') {
	$x = $bbox[0] + ($bbox[2]-$bbox[0])/2;
	$x = $hw + 10 if $x < $hw + 10;
	$x = $wwidth{$zinc} - $hw - 10if $x > $wwidth{$zinc} - $hw - 10;
	$y = $hh + 10;
    } elsif ($outflag eq 'left') {
	$x = $hw + 10;
	$y = $bbox[1] + ($bbox[3]-$bbox[1])/2;
	$y = $hh + 10 if $y < $hh + 10;
	$y = $wheight{$zinc} - $hh - 10 if $y > $wheight{$zinc} - $hh - 10;
    } elsif ($outflag eq 'right') {
	$x = $wwidth{$zinc} - $hw - 10;
	$y = $bbox[1] + ($bbox[3]-$bbox[1])/2;
	$y = $hh + 10 if $y < $hh + 10;
	$y = $wheight{$zinc} - $hh - 10 if $y > $wheight{$zinc} - $hh - 10;
    } elsif ($outflag eq 'left+top') {
	$x = $hw + 10;
	$y = $hh + 10;
    } elsif ($outflag eq 'left+bottom') {
	$x = $hw + 10;
	$y = $wheight{$zinc} - $hh - 10;
    } elsif ($outflag eq 'right+top') {
	$x = $wwidth{$zinc} - $hw - 10;
	$y = $hh + 10;
    } elsif ($outflag eq 'right+bottom') {
	$x = $wwidth{$zinc} - $hw - 10;
	$y = $wheight{$zinc} - $hh - 10;
    }
    # apply the reverse transformation of topgroup to group $g
    $zinc->tsave(1, 'transfo', 1);
    $zinc->trestore($g, 'transfo');
    # then translate group $g1
    $zinc->coords($g1, [$x, $y]);
    $zinc->raise('zincdebug');
    
} # end itemisoutside



# highlight an item (by cloning it and hiding other found items)
# why cloning? because we can't simply make visible an item which
# belongs to an invisible group.
sub highlightitem {
    
    my ($btn, $zinc, $item, $level) = @_;
    return if $showitemflag or $item == 1;
    $showitemflag = 1;
    &surrounditem($zinc, $item, $level);
    
    $btn->bind('<ButtonRelease>', [\&undohighlightitem, $zinc]) if $btn;

} # end highlightitem


sub undohighlightitem {
    
    my ($btn, $zinc) = @_;
    #print "undohighlightitem\n";
    $btn->bind('ReleaseButton', '') if $btn;
    $zinc->remove('zincdebug');
    $showitemflag = 0;

} # end undohighlightitem


sub surrounditem {
    
    my ($zinc, $item, $level) = @_;
    $zinc->remove("zincdebug");
    # cloning
    my $clone = $zinc->clone($item, -visible => 1, -tags => ['zincdebug']);
    $zinc->tsave(1, 'zoom+move', 1);
    $zinc->chggroup($clone, 1, 1);
    my @bbox = $zinc->bbox($clone);
    # create a rectangle around 
    if (scalar @bbox == 4) {
	# If item is visible, rectangle is drawm surround it.
	# Else, a warning is displayed.
	unless (&itemisoutside($zinc, @bbox)) {
	    if (defined($level) and $level > 0) {
		my $r = $zinc->add('rectangle', 1,
				   [$bbox[0] - 10, $bbox[1] - 10,
				    $bbox[2] + 10, $bbox[3] + 10],
				   -linewidth => 0,
				   -filled => 1,
				   -tags => ['zincdebug', 'zincdebugdecorator'],
				   -fillcolor => "gray20");
		$zinc->itemconfigure($r, -fillcolor => "gray80") if $level == 1;
	    } 
	    my $i = 0;
	    for ('white', 'red', 'white') {
		$zinc->add('rectangle', 1,
			   [$bbox[0] - 5 - 2*$i, $bbox[1] - 5 - 2*$i,
			    $bbox[2] + 5 + 2*$i, $bbox[3] + 5 + 2*$i],
			   -linecolor => $_,
			   -linewidth => 1,
			   -tags => ['zincdebug', 'zincdebugdecorator']);
		$i++;
	    }
	}
    }
    # raise
    $zinc->trestore('zincdebugdecorator', 'zoom+move');
    $zinc->raise('zincdebug');
    $zinc->raise($clone);

} # end surrounditem


# functions related to transformation animations
sub showtransfo {
    
    my ($btn, $zinc, $item, $level) = @_;
    my $anim = &highlighttransfo($zinc, $item, $level);
    $btn->bind('<ButtonRelease>', [\&undohighlighttransfo, $zinc, $anim]) if $btn;

} # end showtransfo


sub highlighttransfo {
    
    my ($zinc, $item, $level) = @_;
    $zinc->remove("zincdebug");
    my $g = $zinc->add('group', 1);
    my $g0 = $zinc->add('group', $g, -alpha => 0);
    my $g1 = $zinc->add('group', $g);
    # clone item and reset its transformation
    my $clone0 = $zinc->clone($item, -visible => 1, -tags =>['zincdebug']);
    $zinc->treset($clone0);
    # clone item and preserve its transformation
    my $clone1 = $zinc->clone($item, -visible => 1, -tags => ['zincdebug']);
    # move clones is dedicated group
    $zinc->chggroup($clone0, $g0, 1);
    $zinc->chggroup($clone1, $g1, 1);
    # create a rectangle around 
    my @bbox0  = $zinc->bbox($g);
    if (scalar @bbox0 == 4) {
	$zinc->tsave(1, 'transfo', 1);
	my @bbox = $zinc->transform(1, $g, [@bbox0]);
	# If item is visible, rectangle is drawm surround it.
	# Else, a warning is displayed.
	unless (&itemisoutside($zinc, @bbox0)) {
	    my $r = $zinc->add('rectangle', $g,
			       [$bbox[0] - 10, $bbox[1] - 10,
				$bbox[2] + 10, $bbox[3] + 10],
			       -filled => 1,
			       -linewidth => 0,
			       -tags => ['zincdebug'],
			       -fillcolor => "gray90");
	    $zinc->itemconfigure($r, -fillcolor => "gray50") if $level == 1;
	    $zinc->itemconfigure($r, -fillcolor => "gray20") if $level == 2;
	    $zinc->trestore($r, 'transfo');
	}
    }
    # raise
    $zinc->raise($g);
    $zinc->raise($g0);
    $zinc->raise($g1);
    # animation
    my $anim;
    if ($zinc->cget(-render) == 0) {
	$anim = $zinc->after(150, [sub {
	    $zinc->itemconfigure($g1, -visible => 0);
	    $zinc->itemconfigure($g0, -visible => 1);
	    $zinc->update;
	}]);
    } else {
	my $maxsteps = 5;
	$step = $maxsteps;
	$anim = $zinc->repeat(100, [sub {
	    return if $step < 0;
	    $zinc->itemconfigure($g1, -alpha => ($step)*100/$maxsteps);
	    $zinc->itemconfigure($g0, -alpha => ($maxsteps-$step)*100/$maxsteps);
	    $zinc->update;
	    $step--;
	}]);


    }
    return $anim;

} # end highlighttransfo


sub undohighlighttransfo {
    
    my ($btn, $zinc, $anim) = @_;
    $btn->bind('ReleaseButton', '') if $btn;
    $zinc->remove('zincdebug');
    $zinc->afterCancel($anim);

} # end undohighlighttransfo


#---------------------------------------------------------------------------
#
# Snapshot functions
#
#---------------------------------------------------------------------------

# print a zinc window in png format
sub printWindow {
    
    exit if $saving;
    $saving = 1;
    my ($zinc) = @_;
    my $basename = $cmdoptions{snapshotBasename};
    my $id = $zinc->id;
    my $filename = $basename . $imagecounter . ".png";
    $imagecounter++;
    my $original_cursor = ($zinc->configure(-cursor))[3];
    $zinc->configure(-cursor => 'watch');
    $zinc->update;
    my $res = system("import", -window, $id, $filename);
    $zinc->configure(-cursor => $original_cursor);
    
    $saving = 0;
    if ($res) {
	&showErrorWhilePrinting($zinc, $res)
	}
    else {
	my $dir = `pwd`; chomp ($dir);
	print "Tk::Zinc::Debug: Zinc window snapshot saved in $dir". "/$filename\n";
    }

} # end printWindow


# display complete help screen
sub showErrorWhilePrinting {
    
    my ($zinc, $res) = @_;
    my $dir = `pwd`; chomp ($dir);
    $help_print->destroy if $help_print and Tk::Exists($help_print);
    $help_print = $zinc->Dialog(-title => 'Zinc Print info',
				-text =>
				"To acquire a TkZinc window snapshot, you must " .
				"have access to the import command, which is ".
				"part of imageMagic package\n\n".
				"You must also have the rights to write ".
				"in the current dir : $dir",
				-bitmap => 'warning',
				);
    $help_print->after(300, sub {$help_print->grabRelease});
    $help_print->Show();

} # end showErrorWhilePrinting

#---------------------------------------------------------------------------
#
# Help functions
#
#---------------------------------------------------------------------------

# display help about tree
sub showHelpAboutTree {
    
    my $zinc = shift;
    $helptree_tl->destroy if $helptree_tl and Tk::Exists($helptree_tl);
    $helptree_tl = $tree_tl->Toplevel;
    $helptree_tl->title("Help about Tree");

    my $text = $helptree_tl->Scrolled('Text',
					-font => scalar $zinc->cget(-font),
					-wrap => 'word',
					-foreground => 'gray10',
					-scrollbars => 'osoe',
					);
    &wheelmousebindings($text);
    $text->tagConfigure('keyword', -foreground => 'darkblue');
    $text->insert('end', "\nNAVIGATION IN TREE\n\n");
    $text->insert('end', "<Up>", "keyword");
    $text->insert('end', " arrow key moves the anchor point to the item right on ".
		  "top of the current anchor item. ");
    $text->insert('end', "<Down>", "keyword");
    $text->insert('end', " arrow key moves the anchor point to the item right below ".
		  "the current anchor item. ");
    $text->insert('end', "<Left>", "keyword");
    $text->insert('end', " arrow key moves the anchor to the parent item of the ".
		  "current anchor item. ");
    $text->insert('end', "<Right>", "keyword");
    $text->insert('end', " moves the anchor to the first child of the current anchor ".
		  "item. If the current anchor item does not have any children, moves ".
		  "the anchor to the item right below the current anchor item.\n\n");
    $text->insert('end', "\nHIGHLIGHTING ITEMS\n\n");
    $text->insert('end', "To display item's features, ");
    $text->insert('end', "double-click", "keyword");
    $text->insert('end', " on it, press ");
    $text->insert('end', "<Return>", "keyword");
    $text->insert('end', " key or click on the ");
    $text->insert('end', "Attributes", "keyword");
    $text->insert('end', " button.\n\n");
    $text->insert('end', "To highlight item in the application, simply ");
    $text->insert('end', "click", "keyword");
    $text->insert('end', " on it.");
    &infoAboutHighlighting($text);
    $text->insert('end', "\n\n\nBUILDING CODE\n\n");
    $text->insert('end', "To build perl code, select a branch or a leaf ".
		  "and click on the ");
    $text->insert('end', "Build code", "keyword");
    $text->insert('end', " button. Then select an output file with the ".
		  "file selector.\n\n");
     $text->configure(-state => 'disabled');
    
    $helptree_tl->Button(-command => sub {$helptree_tl->destroy},
			 -text => 'Close')->pack(-side => 'bottom',
						 -pady => 10);
    $text->pack->pack(-side => 'top', -pady => 10, -padx => 10);

} # end showHelpAboutTree


sub showHelpAboutCoords {
    
    my $zinc = shift;
    $helpcoords_tl->destroy if $helpcoords_tl and Tk::Exists($helpcoords_tl);
    $helpcoords_tl = $zinc->Toplevel;
    $helpcoords_tl->title("Help about coordinates");

    my $text = $helpcoords_tl->Scrolled('Text',
				      -font => scalar $zinc->cget(-font),
				      -wrap => 'word',
				      -height => 30,
				      -foreground => 'gray10',
				      -scrollbars => 'oe',
				      );
    &wheelmousebindings($text);
    $text->tagConfigure('keyword', -foreground => 'darkblue');
    $text->tagConfigure('title', -foreground => 'ivory',
			-background => 'gray60',
			-spacing1 => 3,
			-spacing3 => 3);

    
    $text->insert('end', " To display a contour\n", 'title');
    $text->insert('end', "Press button labeled ");
    $text->insert('end', 'Contour i', 'keyword');
    $text->insert('end', " (*). Release it to hide contour.");
    $text->insert('end', "\n\n");
    $text->insert('end', " To display all the points of a contour\n", 'title');
    $text->insert('end', "Press button labeled ");
    $text->insert('end', 'n points', 'keyword');
    $text->insert('end', " (*). Release it to hide points. First plot is ".
		  "particularized by a circle, last one by a double circle. ".
		  "Non-filled plots represent control points of a Bezier curve.");
    $text->insert('end', "\n\n");
    $text->insert('end', " To navigate in the contour\n", 'title');
    $text->insert('end', "Select first a point by clicking in the coordinates table ");
    $text->insert('end', "(*). Th corresponding plot is displayed. Then use the ");
    $text->insert('end', "Up/Down", 'keyword');
    $text->insert('end', " (or ");
    $text->insert('end', "Left/Right", 'keyword');
    $text->insert('end', ") arrows keys to navigate in the contour");
    $text->insert('end', "\n\n");
    $text->insert('end', "\n\n");
    $text->insert('end', "(*) The color of displayed elements depends on the mouse ".
		  "button you press.");
    $text->insert('end', "\n\n");
    $text->configure(-state => 'disabled');
    
    $helpcoords_tl->Button(-command => sub {$helpcoords_tl->destroy},
			 -text => 'Close')->pack(-side => 'bottom',
						 -pady => 10);
    $text->pack->pack(-side => 'top', -pady => 10, -padx => 10);

} # end showHelpAboutCoords



sub infoAboutHighlighting {
    
    my $text = shift;
    $text->insert('end', "By default, using ");
    $text->insert('end', "left mouse button", "keyword");
    $text->insert('end', ", highlighting is done by raising selected item and drawing ".
		  "a rectangle arround. ");
    $text->insert('end', "In order to improve visibility, ");
    $text->insert('end', "item will be light backgrounded if you use ");
    $text->insert('end', "center mouse button", "keyword");
    $text->insert('end', " and dark backgrounded if you use ");
    $text->insert('end', "right mouse button", "keyword");
    $text->insert('end', ". ");
    
} # end infoAboutHighlighting


sub entryballoonhelp {

    my $e = shift;
    my $msg = shift;
    $msg .= "Editable field. To restore the inital value\n".
	    "after edition, enter <Control-z> sequence. ";
    $balloonhelp->attach($e, -balloonposition => 'mouse',
			 -balloonmsg => $msg);
    
} # end entryballoonhelp


sub balloonhelp {
    
    my $b = $control_tl->Balloon(-balloonposition => 'widget',
				 -font => '6x13');
    $b->attach($button{zn},-balloonmsg =>
	       "Widget instance selector. Use it when \n".
	       "your application takes more than one  \n".
	       "TkZinc instance. When this mode is on,\n".
	       "select the TkZinc instance you want   \n".
	       "inspect just by clicking on it.       ");
    $b->attach($button{findenclosed}, -balloonmsg =>
	       "Inspect all items *enclosed* in a  \n".
	       "rectangular area. When this mode is\n".
	       "selected, draw rectangle using left\n".
	       "mouse button.                      ");
    $b->attach($button{findoverlap}, -balloonmsg =>
	       "Inspect all items which *overlap* \n".
	       "a rectangular area. When this mode\n".
	       "is selected, draw rectangle using \n".
	       "left mouse button.                ");
    $b->attach($button{tree}, -balloonmsg =>
	       #"Display the items hierarchy. Can\n".
	       #"build perl code corresponding to\n".
	       #"a specific branch.              ");
	       "Display the items hierarchy. Provide\n".
	       "some related functions, like building\n".
	       "perl code corresponding to a branch.");
    $b->attach($button{item}, -balloonmsg =>
	       "Locate an item in the items tree.  \n".
	       "When this mode is on, select in   \n".
	       "your application the item you want\n".
	       "to inspect just by clicking on it.");
    $b->attach($button{id}, -balloonmsg =>
	       "Open an entry field in which you will  \n".
	       "enter an item's id you want to inspect.");
    $b->attach($button{snapshot}, -balloonmsg =>
	       "Snapshot the application window.");
    $b->attach($button{cursorxy}, -balloonmsg =>
	       "Display the device coordinates\n".
	       "of the X cursor.              ");
    $b->attach($button{zoomminus}, -balloonmsg =>
	       "Shrink the top group.");
    $b->attach($button{zoomplus}, -balloonmsg =>
	       "Expand the top group.");
    $b->attach($button{move}, -balloonmsg =>
	       "Translate the top group. When this\n".
	       "mode is selected, move the top    \n".
	       "group using left mouse button.    ");
    $b->attach($button{balloon},-balloonmsg =>
	       "Balloon help toggle.");
    $b->attach($button{close},-balloonmsg =>
	       "Close this buttons bar.");
    return $b;

} # end balloonhelp



#---------------------------------------------------------------------------
#
# Bitmaps creation for the buttons of the control bar 
#
#---------------------------------------------------------------------------

sub createBitmaps {

    my $zinc = shift;
    my $bitmaps;
    
    $bitmaps->{close} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define close_width 29
#define close_height 29
static unsigned char close_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x02, 0x08, 0x00,
   0x00, 0x07, 0x1c, 0x00, 0x00, 0x0e, 0x0e, 0x00, 0x00, 0x1c, 0x07, 0x00,
   0x00, 0xb8, 0x03, 0x00, 0x00, 0xf0, 0x01, 0x00, 0x00, 0xe0, 0x00, 0x00,
   0x00, 0xf0, 0x01, 0x00, 0x00, 0xb8, 0x03, 0x00, 0x00, 0x1c, 0x07, 0x00,
   0x00, 0x0e, 0x0e, 0x00, 0x00, 0x07, 0x1c, 0x00, 0x00, 0x02, 0x08, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
EOF
    $bitmaps->{zn} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define focus_width 29
#define focus_height 29
static unsigned char focus_bits[] = {
  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  0x00, 0x00, 0x00, 0x00, 0xe0, 0x3f, 0x00, 0x00, 0x60, 0x38, 0x00, 0x00,
  0x20, 0x18, 0x00, 0x00, 0x00, 0x1c, 0x00, 0x00, 0x00, 0x8e, 0x33, 0x00,
  0x00, 0x06, 0x7b, 0x00, 0x00, 0x07, 0x67, 0x00, 0x80, 0x03, 0x63, 0x00,
  0xc0, 0x01, 0x63, 0x00, 0xc0, 0x00, 0x63, 0x00, 0xe0, 0x20, 0x63, 0x00,
  0x70, 0x30, 0x63, 0x00, 0xf0, 0xbf, 0xe7, 0x00, 0x00, 0x00, 0x00, 0x00,
  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, };
EOF
    $bitmaps->{findenclosed} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define findenclosed_width 29
#define findenclosed_height 29
static unsigned char findenclosed_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x3c, 0x00, 0x00, 0x00,
   0xfc, 0xff, 0xff, 0x03, 0xfc, 0xff, 0xff, 0x03, 0x3c, 0x00, 0x00, 0x03,
   0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03,
   0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03,
   0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03,
   0x18, 0x80, 0x00, 0x03, 0x18, 0x00, 0x01, 0x03, 0x18, 0x00, 0x22, 0x03,
   0x18, 0x00, 0x24, 0x03, 0x18, 0x00, 0x28, 0x03, 0x18, 0x00, 0x20, 0x03,
   0x18, 0x00, 0x3e, 0x03, 0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03,
   0xf8, 0xff, 0xff, 0x03, 0xf8, 0xff, 0xff, 0x03, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
EOF
    $bitmaps->{findoverlap} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define findoverlap_width 29
#define findoverlap_height 29
static unsigned char findoverlap_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x3c, 0x00, 0x00, 0x00,
   0xfc, 0xb6, 0x6d, 0x03, 0xfc, 0xb6, 0x6d, 0x03, 0x3c, 0x00, 0x00, 0x00,
   0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00,
   0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00,
   0x18, 0x00, 0x00, 0x03, 0x18, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00,
   0x18, 0x80, 0x00, 0x03, 0x18, 0x00, 0x01, 0x03, 0x00, 0x00, 0x22, 0x00,
   0x18, 0x00, 0x24, 0x03, 0x18, 0x00, 0x28, 0x03, 0x00, 0x00, 0x20, 0x00,
   0x18, 0x00, 0x3e, 0x03, 0x18, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00, 0x00,
   0xd8, 0xb6, 0x6d, 0x03, 0xd8, 0xb6, 0x6d, 0x03, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
EOF
    $bitmaps->{tree} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define tree_width 29
#define tree_height 29
static unsigned char tree_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0xf0, 0x07, 0x00, 0x00, 0x10, 0x04, 0x00, 0x00, 0x10, 0x04, 0x00,
   0xc0, 0x1f, 0x04, 0x00, 0x40, 0x10, 0x04, 0x00, 0x40, 0x10, 0x04, 0x00,
   0x40, 0xf0, 0x07, 0x00, 0x40, 0x00, 0x00, 0x00, 0x40, 0x00, 0xe0, 0x0f,
   0x40, 0x00, 0x20, 0x08, 0x7c, 0x00, 0x20, 0x08, 0x40, 0x00, 0x3f, 0x08,
   0x40, 0x00, 0x21, 0x08, 0x40, 0x00, 0x21, 0x08, 0x40, 0x00, 0xe1, 0x0f,
   0x40, 0x00, 0x01, 0x00, 0x40, 0x00, 0x01, 0x00, 0xc0, 0xff, 0x01, 0x00,
   0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x01, 0x00,
   0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x5f, 0x01, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
EOF
    $bitmaps->{item} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define item_width 29
#define item_height 29
static unsigned char item_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x08, 0x00, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0xf0, 0x00, 0x00, 0x00,
   0xe0, 0x03, 0x00, 0x00, 0xe0, 0x07, 0x00, 0x00, 0xc0, 0x1f, 0x00, 0x00,
   0xc0, 0x7f, 0x00, 0x00, 0x80, 0xff, 0x01, 0x00, 0x00, 0xff, 0x03, 0x00,
   0x00, 0xff, 0x00, 0x00, 0x00, 0x7e, 0x00, 0x00, 0x00, 0xfe, 0x00, 0x00,
   0x00, 0xdc, 0x01, 0x00, 0x00, 0x8c, 0x03, 0x00, 0x00, 0x08, 0x07, 0x00,
   0x00, 0x00, 0x0e, 0x00, 0x00, 0x00, 0x1c, 0x00, 0x00, 0x00, 0x38, 0x00,
   0x00, 0x00, 0x70, 0x00, 0x00, 0x00, 0xe0, 0x00, 0x00, 0x00, 0x40, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
EOF
    $bitmaps->{id} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define id_width 29
#define id_height 29
static unsigned char id_bits[] = {
  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  0x00, 0x00, 0x00, 0x00, 0x00, 0x06, 0x0e, 0x00, 0x00, 0x06, 0x0c, 0x00,
  0x00, 0x00, 0x0c, 0x00, 0x00, 0x00, 0x0c, 0x00, 0x00, 0x87, 0x0f, 0x00,
  0x00, 0xc6, 0x0c, 0x00, 0x00, 0x66, 0x0c, 0x00, 0x00, 0x66, 0x0c, 0x00,
  0x00, 0x66, 0x0c, 0x00, 0x00, 0x66, 0x0c, 0x00, 0x00, 0x66, 0x0c, 0x00,
  0x00, 0xc6, 0x0c, 0x00, 0x00, 0x8f, 0x1f, 0x00, 0x00, 0x00, 0x00, 0x00,
  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, };
EOF
    $bitmaps->{snapshot} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define snapshot_width 29
#define snapshot_height 29
static unsigned char snapshot_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x03, 0x1f, 0x00,
   0x80, 0x03, 0x11, 0x00, 0xe0, 0xff, 0xf1, 0x00, 0xf0, 0xff, 0xff, 0x01,
   0xf0, 0xff, 0xff, 0x01, 0xf0, 0xff, 0xff, 0x01, 0xf0, 0x0f, 0xfe, 0x01,
   0xf0, 0xe7, 0xfc, 0x01, 0xf0, 0x13, 0xf9, 0x01, 0xf0, 0x09, 0xf2, 0x01,
   0xf0, 0x05, 0xf4, 0x01, 0xf0, 0x05, 0xf4, 0x01, 0xf0, 0x05, 0xf4, 0x01,
   0xf0, 0x09, 0xf2, 0x01, 0xf0, 0x13, 0xf9, 0x01, 0xf0, 0xe7, 0xfc, 0x01,
   0xf0, 0x0f, 0xfe, 0x01, 0xf0, 0xff, 0xff, 0x01, 0xe0, 0xff, 0xff, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
EOF
    $bitmaps->{zoomminus} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define zoomminus_width 29
#define zoomminus_height 29
static unsigned char zoomminus_bits[] = {
   0x00, 0x0e, 0x00, 0x00, 0xc0, 0x71, 0x00, 0x00, 0x30, 0x80, 0x01, 0x00,
   0x08, 0x00, 0x02, 0x00, 0x04, 0x00, 0x04, 0x00, 0x04, 0x00, 0x04, 0x00,
   0x02, 0x00, 0x08, 0x00, 0x02, 0x00, 0x08, 0x00, 0x02, 0x00, 0x08, 0x00,
   0xe1, 0xff, 0x10, 0x00, 0xe1, 0xff, 0x10, 0x00, 0xe1, 0xff, 0x10, 0x00,
   0x02, 0x00, 0x08, 0x00, 0x02, 0x00, 0x08, 0x00, 0x02, 0x00, 0x08, 0x00,
   0x04, 0x00, 0x04, 0x00, 0x04, 0x00, 0x04, 0x00, 0x08, 0x00, 0x02, 0x00,
   0x30, 0x80, 0x05, 0x00, 0xc0, 0x71, 0x28, 0x00, 0x00, 0x0e, 0x70, 0x00,
   0x00, 0x00, 0xf8, 0x00, 0x00, 0x00, 0xf0, 0x01, 0x00, 0x00, 0xe0, 0x03,
   0x00, 0x00, 0xc0, 0x07, 0x00, 0x00, 0x80, 0x0f, 0x00, 0x00, 0x00, 0x1f,
   0x00, 0x00, 0x00, 0x0e, 0x00, 0x00, 0x00, 0x04};
EOF

    $bitmaps->{zoomplus} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define zoomplus_width 29
#define zoomplus_height 29
static unsigned char zoomplus_bits[] = {
   0x00, 0x0e, 0x00, 0x00, 0xc0, 0x71, 0x00, 0x00, 0x30, 0x80, 0x01, 0x00,
   0x08, 0x00, 0x02, 0x00, 0x04, 0x00, 0x04, 0x00, 0x04, 0x0e, 0x04, 0x00,
   0x02, 0x0e, 0x08, 0x00, 0x02, 0x0e, 0x08, 0x00, 0x02, 0x0e, 0x08, 0x00,
   0xe1, 0xff, 0x10, 0x00, 0xe1, 0xff, 0x10, 0x00, 0xe1, 0xff, 0x10, 0x00,
   0x02, 0x0e, 0x08, 0x00, 0x02, 0x0e, 0x08, 0x00, 0x02, 0x0e, 0x08, 0x00,
   0x04, 0x0e, 0x04, 0x00, 0x04, 0x00, 0x04, 0x00, 0x08, 0x00, 0x02, 0x00,
   0x30, 0x80, 0x05, 0x00, 0xc0, 0x71, 0x28, 0x00, 0x00, 0x0e, 0x70, 0x00,
   0x00, 0x00, 0xf8, 0x00, 0x00, 0x00, 0xf0, 0x01, 0x00, 0x00, 0xe0, 0x03,
   0x00, 0x00, 0xc0, 0x07, 0x00, 0x00, 0x80, 0x0f, 0x00, 0x00, 0x00, 0x1f,
   0x00, 0x00, 0x00, 0x0e, 0x00, 0x00, 0x00, 0x04};
EOF

    $bitmaps->{move} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define hand_width 29
#define hand_height 29
static unsigned char hand_bits[] = {
   0x00, 0xe0, 0x00, 0x00, 0x00, 0x10, 0x01, 0x00, 0x80, 0x13, 0x0f, 0x00,
   0x40, 0x12, 0x11, 0x00, 0x40, 0x14, 0x11, 0x00, 0x40, 0x14, 0xd1, 0x01,
   0x80, 0x14, 0x31, 0x02, 0x80, 0x14, 0x31, 0x02, 0x80, 0x18, 0x31, 0x02,
   0x80, 0x18, 0x31, 0x02, 0x00, 0x11, 0x31, 0x02, 0x00, 0x11, 0x11, 0x01,
   0x1c, 0x11, 0x11, 0x01, 0x22, 0x01, 0x11, 0x01, 0x42, 0x01, 0x10, 0x01,
   0x84, 0x01, 0x00, 0x01, 0x88, 0x01, 0x00, 0x01, 0x08, 0x01, 0x00, 0x02,
   0x08, 0x02, 0x00, 0x02, 0x10, 0x00, 0x00, 0x02, 0x20, 0x00, 0x00, 0x02,
   0x20, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x02, 0x40, 0x00, 0x00, 0x01,
   0x80, 0x00, 0x80, 0x00, 0x00, 0x01, 0x80, 0x00, 0x00, 0x06, 0x40, 0x00,
   0x00, 0x08, 0x40, 0x00, 0x00, 0x08, 0x40, 0x00};
EOF

    $bitmaps->{balloon} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define balloon_width 29
#define balloon_height 29
static unsigned char balloon_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xff, 0xff, 0x00,
   0x10, 0x00, 0x00, 0x01, 0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02,
   0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02,
   0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02,
   0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02, 0x08, 0x00, 0x00, 0x02,
   0x10, 0x00, 0x00, 0x01, 0xe0, 0xe0, 0xff, 0x00, 0x00, 0x11, 0x00, 0x00,
   0x00, 0x09, 0x00, 0x00, 0x80, 0x04, 0x00, 0x00, 0x80, 0x02, 0x00, 0x00,
   0x40, 0x01, 0x00, 0x00, 0xc0, 0x00, 0x00, 0x00, 0x20, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
EOF

    $bitmaps->{cursorxy} = $zinc->toplevel->Bitmap(-data => <<EOF);
#define balloon_width 29
#define balloon_height 29
static unsigned char balloon_bits[] = {
  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00,
  0x00, 0x06, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, 0x00, 0x7c, 0x00, 0x00,
  0x00, 0x1c, 0x00, 0x00, 0x00, 0x28, 0x00, 0x00, 0x00, 0x48, 0x00, 0x00,
  0x00, 0x80, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x02, 0x00,
  0x00, 0x00, 0x04, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
  0x30, 0x06, 0x8c, 0x01, 0x70, 0x07, 0x8c, 0x01, 0x60, 0x03, 0x8c, 0x01,
  0xc0, 0x01, 0xd8, 0x00, 0xc0, 0x01, 0xd8, 0x00, 0x60, 0xe3, 0xd8, 0x00,
  0x70, 0x66, 0x70, 0x00, 0x30, 0x66, 0x70, 0x00, 0x00, 0x30, 0x60, 0x00,
  0x00, 0x30, 0x30, 0x00, 0x00, 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00,
  0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, };
EOF

    return $bitmaps;
   
} # end  createBitmaps


#---------------------------------------------------------------------------
#
# Miscellaneous
#
#---------------------------------------------------------------------------

sub getsize {
    
    my $zinc = shift;
    $wwidth{$zinc} = $zinc->cget(-width);
    $wheight{$zinc} = $zinc->cget(-height);
        
} # end getsize


sub entryoption {
    
    my ($fm, $item, $zinc, $option, $def, $widthmax, $widthmin, $height) = @_;
    my $arrayflag;
    unless (defined $def) {
	my @def = $zinc->itemcget($item, $option);
	if (@def > 1) {
	    $arrayflag = 1;
	    $def = join(', ', @def);
	} else {
	    $def = $def[0];
	}
    }
    $def = "" unless defined $def;
    my $i0;
    my $e;
    if ($def =~ /\n/) {
	$height = 1 unless defined($height);
	$e = $fm->Text(-height => $height, -width => 1, -wrap => 'none');
	$i0 = '0.0';
    } else {
	$e = $fm->Entry();
	$i0 = 0;
    }
    &entryballoonhelp($e);
    my $width = length($def);
    $width = $widthmax if defined($widthmax) and $width > $widthmax;
    $width = $widthmin if defined($widthmin) and $width < $widthmin;
    $e->configure(-width => $width);
    if ($defaultoptions{$item}->{$option} and
	$def ne $defaultoptions{$item}->{$option}) {
	$e->configure(-foreground => 'blue');
    }
    
    $e->insert($i0, $def);
    $e->bind('<Control-z>', sub {
	return unless defined $defaultoptions{$item}->{$option};
	my $bg = $e->cget(-background);
	$zinc->itemconfigure($item, $option => $defaultoptions{$item}->{$option});
	$e->delete($i0, 'end');
	$e->insert($i0, $defaultoptions{$item}->{$option});
	$e->configure(-background => 'ivory');
	$e->after(80, sub {$e->configure(-background => $bg, -foreground => 'black')});
    });
    $e->bind('<Key-Return>',
	     sub {my $val = $e->get;
		  my $bg = $e->cget(-background);
		  $e->configure(-background => 'ivory');
		  if ($def ne $val) {
		      $defaultoptions{$item}->{$option} = $def
			  unless $defaultoptions{$item}->{$option};
		  }
		  my $fg = ($val ne $defaultoptions{$item}->{$option}) ?
		      'blue' : 'black';
		  $e->after(80, sub {
		      $e->configure(-background => $bg, -foreground => $fg);
		  });
		  if ($arrayflag) {
		      $zinc->itemconfigure($item, $option => [split(/,/, $val)]);
		  } else {
		      $zinc->itemconfigure($item, $option => $val);
		  }
	      });

    return $e;

} # end entryoption


sub entrytransfo {
    
    my ($fm, $item, $zinc, $attr, $def, $var, $width, $set_cb) = @_;
    my $i0;
    my $e;
    $e = $fm->Entry(-textvariable => $var);
    &entryballoonhelp($e);
    $i0 = 0;
    $width = length($def) unless $width;
    $e->configure(-width => $width);   
    $e->insert($i0, $def);
    $e->bind('<Control-z>', sub {
	my $bg = $e->cget(-background);
	$e->delete($i0, 'end');
	$e->insert($i0, $def);
	$e->configure(-background => 'ivory');
	$e->after(80, sub {$e->configure(-background => $bg, -foreground => 'black')});
	&$set_cb;
    });
    $e->bind('<Key-Return>',
	     sub {my $val = $e->get;
		  my $bg = $e->cget(-background);
		  $e->configure(-background => 'ivory');
		  my $fg = ($val ne $def) ? 'blue' : 'black';
		  $e->after(80, sub {
		      $e->configure(-background => $bg, -foreground => $fg);
		  });
		  &$set_cb;
	      });

    return $e;

} # end entrytransfo


sub instances {
    
    return @instances;
    
} # end instances


sub saveMotionBinding {

    my ($zinc) = @_;
    for my $seq ('Motion') {
	$userbindings{$zinc}->{$seq} = $zinc->Tk::bind('<'.$seq.'>')
	    unless defined $userbindings{$zinc}->{$seq};
	$userbindings{$zinc}->{$seq} = "" unless defined $userbindings{$zinc}->{$seq};
	$zinc->Tk::bind('<'.$seq.'>', "");
    }
    
} # end saveMotionBinding


sub restoreMotionBinding {

    my ($zinc) = @_;
    for my $seq ('Motion') {
	next unless defined $userbindings{$zinc}->{$seq};
	$zinc->Tk::bind('<'.$seq.'>', $userbindings{$zinc}->{$seq});
	delete $userbindings{$zinc}->{$seq};
    }
    
} # end restoreMotionBinding


sub saveDragAndDropBindings {

    my ($zinc) = @_;
    for my $seq ('ButtonPress-1', 'B1-Motion', 'ButtonRelease-1') {
	$userbindings{$zinc}->{$seq} = $zinc->Tk::bind('<'.$seq.'>')
	    unless defined $userbindings{$zinc}->{$seq};
	$userbindings{$zinc}->{$seq} = "" unless defined $userbindings{$zinc}->{$seq};
	#print "saveDragAndDropBindings seq=$seq cb=$userbindings{$zinc}->{$seq}\n";
	$zinc->Tk::bind('<'.$seq.'>', "");
    }
    
} # end saveDragAndDropBindings


sub restoreDragAndDropBindings {

    my ($zinc) = @_;
    for my $seq ('ButtonPress-1', 'B1-Motion', 'ButtonRelease-1') {
	next unless defined $userbindings{$zinc}->{$seq};
	$zinc->Tk::bind('<'.$seq.'>', $userbindings{$zinc}->{$seq});
	#print "restoreDragAndDropBindings seq=$seq cb=$userbindings{$zinc}->{$seq}\n";
	delete $userbindings{$zinc}->{$seq};
    }
    
} # end restoreDragAndDropBindings


sub newinstance {
    
    my $zinc = shift;
    return if $instances{$zinc};
    $zinc->toplevel->Tk::bind('<Key-Escape>', \&Tk::Zinc::Debug::deiconify);
    $instances{$zinc} = 1;    
    push(@instances, $zinc);
    $zinc->Tk::focus;
    $selectedzinc = $zinc;
    
} # end newinstance


sub deiconify {

    $button{zn}->destroy() if @instances == 1 and Tk::Exists($button{zn});
    $control_tl->deiconify();
    for (values %result_tl) {
	$_->deiconify if Tk::Exists($_);
    }
    for (values %coords_tl) {
	$_->deiconify if Tk::Exists($_);
    }
    for (values %alloptions_tl) {
	$_->deiconify if Tk::Exists($_);
    }
    $tree_tl->deiconify if Tk::Exists($tree_tl);
    $search_tl->deiconify if Tk::Exists($search_tl);
    $searchtree_tl->deiconify if Tk::Exists($searchtree_tl);
    $cursorxy_tl->deiconify if Tk::Exists($cursorxy_tl);
    $control_tl->raise();

} # end deiconify


sub iconify {

    for (values %result_tl) {
	$_->withdraw if Tk::Exists($_);
    }
    for (values %coords_tl) {
	$_->withdraw if Tk::Exists($_);
    }
    for (values %alloptions_tl) {
	$_->withdraw if Tk::Exists($_);
    }
    $tree_tl->withdraw if Tk::Exists($tree_tl);
    $search_tl->withdraw if Tk::Exists($search_tl);
    $searchtree_tl->withdraw if Tk::Exists($searchtree_tl);
    $cursorxy_tl->withdraw if Tk::Exists($cursorxy_tl);
    $control_tl->withdraw();

} # end iconify

# wheelmousebindings doesn't work for Tk::Pane widgets...
sub wheelmousebindings {
    my $w = shift;
    my $count = shift;
    $count = 3 unless $count > 0;

    $w->bind('<Control-ButtonPress-4>', sub {$w->yview('scroll', -1, 'page')});
    $w->bind('<Shift-ButtonPress-4>', sub {$w->yview('scroll', -1, 'unit')});
    $w->bind('<ButtonPress-4>', sub {$w->yview('scroll', -$count, 'unit')});
    
    $w->bind('<Control-ButtonPress-5>', sub {$w->yview('scroll', 1, 'page')});
    $w->bind('<Shift-ButtonPress-5>', sub {$w->yview('scroll', 1, 'unit')});
    $w->bind('<ButtonPress-5>', sub {$w->yview('scroll', $count, 'unit')});

} # end wheelmousebindings

1;

__END__

    
=head1 NAME

Tk::Zinc::Debug - a perl module for analysing a Zinc application. 


=head1 SYNOPSIS

 perl -MTk::Zinc::Debug zincscript [zincscript-opts] [Debug-initopts]
    
     or
    
 use Tk::Zinc::Debug;
 my $zinc = MainWindow->new()->Zinc()->pack;
 Tk::Zinc::Debug::init($zinc, [options]);


=head1 DESCRIPTION

Tk::Zinc::Debug provides an interface to help developers to inspect Zinc applications.

Press the B<Escape> key in the toplevel of your application to display the Tk::Zinc::Debug buttons bar.


Features :

=over
    
=item B<o> scan a rectangular area

Scan all items which are enclosed in a rectangular area you have first drawn by drag & drop, or all items which overlap it. Result is a Tk table which presents details (options, coordinates, ...) about found items; you can also highlight a particular item, even if it's not visible, by clicking on its corresponding button in the table. You can also display particular item's features by entering this id in dedicated entry field

=item B<o> display items hierarchy

You can find a particular item's position in the tree and you can highlight items and see their features as described above. You can also generate the perl code corresponding to a selected branch (but images can't be reproduced).

=item B<o> snapshot the application window

In order to illustrate a graphical bug for example.
    
=item B<o> display coordinates of the X cursor.
    
=item B<o> zoom/translate the top group
    
=back


=head2 Loading Tk::Zinc::Debug as a plugin
    
If you load Tk::Zinc::Debug using the -M perl option, B<nothing needs to be added to your code>. In this case, the B<init()> function is automatically invoked with its default attributes for each instance of Zinc widget. You can overload these by passing the same options to the command. 

=head1 FUNCTION


=over

=item B<init>($zinc, ?option => value, ...?)

This function creates required Tk bindings to permit items search. You can specify the following options :

=over

=item E<32>E<32>E<32>B<-optionsToDisplay> => opt1[,..,optN]

Used to display some option's values associated to items of the tree. Expected argument is a string of commas separated options.

=item E<32>E<32>E<32>B<-optionsFormat> => row | column

Defines the display format of option's values. Default is 'row'.
    
=item E<32>E<32>E<32>B<-snapshotBasename> => string

Defines the basename used for the file containing the snaphshot. The filename will be <current­dir>/basename<n>.png  Defaulted to 'zincsnapshot'.

=item E<32>E<32>E<32>B<-expandTagsField> => 0 | 1

Specifies if the tags field in the attributes window will be expanded to show all the items tags (it should take up a lot of space). In the default case (value is set to 0), only the head of the list is displayed.


=back


=back
    

=head1 AUTHOR

Daniel Etienne <etienne@cena.fr>

    
=head1 HISTORY

Oct 5 2004 : transformations are correctly managed in built code. Transfo parameters can be displayed and set. new mode to display coordinateds of X cursor.

Oct 14 2003 : add a control bar, and zoom/translate new functionalities. finditems(), tree(), snapshot() functions become deprecated, initialisation is done using the new init() function.

Oct 07 2003 : contours of curves can be displayed and explored.

Sep 15 2003 : due to CPAN-isation, the ZincDebug module has been renamed Tk::Zinc::Debug

May 20 2003 : perl code can be generated from the items tree, with some limitations concerning transformations and images.

Mar 11 2003 : ZincDebug can manage several instances of Zinc widget. Options of ZincDebug functions can be set on the command line. 

Jan 20 2003 : item's attributes can be edited.

Jan 14 2003 : ZincDebug can be loaded at runtime using the -M perl option without any change in the application's code.

Nov 6 2002 : some additional informations (like tags or other attributes values) can be displayed in the items tree. Add feedback when selected item is not visible because outside window.

Sep 2 2002 : add the tree() function

May 27 2002 : add the snapshot() function contributed by Ch. Mertz.
    
Jan 28 2002 : Zincdebug provides the finditems() function and can manage only one instance of Zinc widget. 

#-----------------------------------------------------------------------------------
#
#      Graphics.pm
#      some graphic design functions
#
#-----------------------------------------------------------------------------------
#  Functions to create complexe graphic component :
#  ------------------------------------------------
#      buildZincItem          (realize a zinc item from description hash table
#                              management of enhanced graphics functions)
#
#      repeatZincItem         (duplication of given zinc item)
#
#  Function to compute complexe geometrical forms :
#  (text header of functions explain options for each form,
#  function return curve coords using control points of cubic curve)
#  -----------------------------------------------------------------
#      roundedRectangleCoords (return curve coords of rounded rectangle)
#      hippodromeCoords       (return curve coords of circus form)
#      ellipseCoords          (return curve coords of ellipse form)
#      polygonCoords          (return curve coords of regular polygon)
#      roundedCurveCoords     (return curve coords of rounded curve)
#      polylineCoords         (return curve coords of polyline)
#      shiftPathCoords        (return curve coords of shifting path)
#      tabBoxCoords           (return curve coords of tabBox's pages)
#      pathLineCoords         (return triangles coords of pathline)
#
#  Function to compute 2D 1/2 relief and shadow :
#  function build zinc items (triangles and curve) to simulate this
#  -----------------------------------------------------------------
#      graphicItemRelief      (return triangle items simulate relief of given item)
#      polylineReliefParams   (return triangle coords and lighting triangles color list)
#      graphicItemShadow      (return triangles and curve items simulate shadow of given item))
#      polylineShadowParams   (return triangle and curve coords and shadow triangles color list))
#
#  Geometrical basic Functions :
#  -----------------------------
#      perpendicularPoint
#      lineAngle
#      lineNormal
#      vertexAngle
#      arc_pts
#      rad_point
#      bezierCompute
#      bezierSegment
#      bezierPoint
#
#  Pictorial Functions  :
#  ----------------------
#      setGradients
#      getPattern
#      getTexture
#      getImage
#      init_pixmaps
#      zincItemPredominantColor
#      ZnColorToRGB
#      hexaRGBcolor
#      createGraduate
#      pathGraduate
#      MedianColor
#      LightingColor
#      RGBtoLCH
#      LCHtoRGB
#      RGBtoHLS
#      HLStoRGB
#
#-----------------------------------------------------------------------------------
#      Authors: Jean-Luc Vinot <vinot@cena.fr>
#
# $Id$ 
#-----------------------------------------------------------------------------------
package Tk::Zinc::Graphics;

use vars qw( $VERSION );
($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/);

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&buildZincItem &repeatZincItem &buidTabBoxItem

	     &roundedRectangleCoords &hippodromeCoords &polygonCoords &ellipseCoords
	     &roundedCurveCoords &polylineCoords &tabBoxCoords &pathLineCoords &shiftPathCoords

	     &perpendicularPoint &lineAngle &vertexAngle &rad_point &arc_pts &lineNormal
	     &curve2polylineCoords &curveItem2polylineCoords &bezierSegment &bezierCompute

	     &graphicItemRelief &graphicItemShadow

	     &setGradients &getPattern &getTexture &getImage &init_pixmaps

	     &hexaRGBcolor &createGraduate &lightingColor &zincItemPredominantColor
	     &MedianColor &RGBtoLCH &LCHtoRGB &RGBtoHLS &HLStoRGB
	     );

use strict;
use Carp;
use Tk;
use Tk::PNG;
use Tk::JPEG;
use Math::Trig;

# constante facteur point directeur (conique -> quadratique)
my $const_ptd_factor = .5523;

# constante white point (conversion couleur espace CIE XYZ)
my ($Xw, $Yw, $Zw) = (95.047, 100.0, 108.883);

# limite globale d'approximation courbe bezier
my $bezierClosenessThreshold = .2;

# initialisation et partage de ressources couleurs et images
my @Gradients;
my %textures;
my %images;
my %bitmaps;



#-----------------------------------------------------------------------------------
# Graphics::buildZincItem
# Création d'un objet Zinc de représentation
#-----------------------------------------------------------------------------------
# types d'items valides :
# les items natifs zinc : group, rectangle, arc, curve, text, icon
# les items ci-après permettent de spécifier des curves 'particulières' :
# -roundedrectangle : rectangle à coin arrondi
#       -hippodrome : hippodrome
#          -ellipse : ellipse un centre 2 rayons
#         -polygone : polygone régulier à n cotés (convexe ou en étoile)
#     -roundedcurve : curve multicontours à coins arrondis (rayon unique)
#         -polyline : curve multicontours à coins arrondis (le rayon pouvant être défini 
#                     spécifiquement pour chaque sommet)
#         -pathline : création d'une ligne 'épaisse' avec l'item Zinc triangles
#                     décalage par rapport à un chemin donné (largeur et sens de décalage)
#                     dégradé de couleurs de la ligne (linéaire, transversal ou double)
#-----------------------------------------------------------------------------------
# paramètres :
# widget : <widget> identifiant du widget Zinc
# parentgroup : <tagOrId> identifiant du group parent
#
# options :
#   -itemtype : type de l'item à construire (type zinc ou metatype)
#     -coords : <coords|coordsList> coordonnées de l'item
# -metacoords : <hastable> calcul de coordonnées par type d'item différent de -itemtype
#   -contours : <contourList> paramètres multi-contours
#     -params : <hastable> arguments spécifiques de l'item à passer au widget
#    -addtags : [list of specific tags] to add to params -tags
#    -texture : <imagefile> ajout d'une texture à l'item
#    -pattern : <imagefile> ajout d'un pattern à l'item
#     -relief : <hastable> création d'un relief à l'item invoque la fonction &graphicItemRelief()
#     -shadow : <hastable> création d'une ombre portée à l'item invoque la fonction &graphicItemShadow()
#      -scale : <scale_factor|[xscale_factor,yscale_factor]> application d'une transformation zinc->scale à l'item
#  -translate : <[dx,dy]> application d'un transformation zinc->translate à l'item.
#     -rotate : <angle> application d'une transformation zinc->rotate (en degré) à l'item
#       -name : <str> nom de l'item
# spécifiques item group :
#       -clip : <coordList|hashtable> paramètres de clipping d'un item group (coords ou item)
#      -items : <hashtable> appel récursif de la fonction permettant d'inclure des items au groupe
#-----------------------------------------------------------------------------------
#
#-----------------------------------------------------------------------------------
sub buildZincItem {
  my ($widget, $parentgroup, %options) = @_;
  $parentgroup = 1 if !$parentgroup;

  my $itemtype = $options{'-itemtype'};
  my $coords = $options{'-coords'};
  my $params = $options{'-params'};

  return unless ($widget and $itemtype and ($coords or $options{'-metacoords'}));

  my $name = ($options{'-name'}) ? $options{'-name'} : 'none';

  my $item;
  my $metatype;
  my (@items, @reliefs, @shadows);
  my @tags;


  #--------------------
  # GEOMETRIE DES ITEMS

  # gestion des types d'items particuliers et à raccords circulaires
  if ($itemtype eq 'roundedrectangle'
      or $itemtype eq 'hippodrome'
      or $itemtype eq 'polygone'
      or $itemtype eq 'ellipse'
      or $itemtype eq 'roundedcurve'
      or $itemtype eq 'polyline'
      or $itemtype eq 'curveline') {

    # par défaut la curve sera fermée -closed = 1
    $params->{'-closed'} = 1 if (!defined $params->{'-closed'});
    $metatype = $itemtype;
    $itemtype = 'curve';

    # possibilité de définir les coordonnées initiales par metatype
    if ($options{'-metacoords'}) {
      $options{'-coords'} = &metaCoords(%{$options{'-metacoords'}});

    }

  # création d'une pathline à partir d'item zinc triangles
  } elsif ($itemtype eq 'pathline') {

    $itemtype = 'triangles';
    if ($options{'-metacoords'}) {
      $coords = &metaCoords(%{$options{'-metacoords'}});

    }

    if ($options{'-graduate'}) {
      my $numcolors = scalar(@{$coords});
      $params->{'-colors'} = &pathGraduate($widget, $numcolors, $options{'-graduate'});
    }

    $coords = &pathLineCoords($coords, %options);


  # création d'une boite à onglet
  } elsif ($itemtype eq 'tabbox') {
    return &buildTabBoxItem($widget, $parentgroup, %options);

  }

  # calcul des coordonnées finales de la curve
  $coords = &metaCoords(-type => $metatype, %options) if ($metatype);


  # gestion du multi-contours (accessible pour tous les types d'items géometriques)
  if ($options{'-contours'} and $metatype) {
    my @contours = @{$options{'-contours'}};
    my $numcontours = scalar(@contours);
    for (my $i = 0; $i < $numcontours; $i++) {
      # radius et corners peuvent être défini spécifiquement pour chaque contour
      my ($type, $way, $addcoords, $radius, $corners, $corners_radius) = @{$contours[$i]};
      $radius = $options{'-radius'} if (!defined $radius);

      my $newcoords = &metaCoords(-type => $metatype,
				  -coords => $addcoords,
				  -radius => $radius,
				  -corners => $corners,
				  -corners_radius => $corners_radius
				 );

      $options{'-contours'}->[$i] = [$type, $way, $newcoords];
    }
  }


  #----------------------
  # REALISATION DES ITEMS

  # ITEM GROUP
  # gestion des coordonnées et du clipping
  if ($itemtype eq 'group') {
    $item = $widget->add($itemtype,
			 $parentgroup,
			 %{$params});

    $widget->coords($item, $coords) if $coords;

    # clipping du groupe par item ou par géometrie
    if ($options{'-clip'}) {
      my $clipbuilder = $options{'-clip'};
      my $clip;

      # création d'un item de clipping
      if ($clipbuilder->{'-itemtype'}) {
	$clip = &buildZincItem($widget, $item, %{$clipbuilder});

      } elsif (ref($clipbuilder) eq 'ARRAY' or $widget->type($clipbuilder)) {
	$clip = $clipbuilder;
      }

      $widget->itemconfigure($item, -clip => $clip) if ($clip);
    }

    # créations si besoin des items contenus dans le groupe
    if ($options{'-items'} and ref($options{'-items'}) eq 'HASH') {
      while (my ($itemname, $itemstyle) = each(%{$options{'-items'}})) {
	$itemstyle->{'-name'} = $itemname if (!$itemstyle->{'-name'});
	&buildZincItem($widget, $item, %{$itemstyle});
      }
    }


  # ITEM TEXT ou ICON
  } elsif ($itemtype eq 'text' or $itemtype eq 'icon') {
    my $imagefile;
    if ($itemtype eq 'icon') {
      $imagefile = $params->{'-image'};
      my $image = &getImage($widget, $imagefile);
      $params->{'-image'} = ($image) ? $image : "";
    }

    $item = $widget->add($itemtype,
		       $parentgroup,
		       -position => $coords,
		       %{$params},
		      );

    $params->{'-image'} = $imagefile if $imagefile;


  # ITEMS GEOMETRIQUES -> CURVE
  } else {

    $item = $widget->add($itemtype,
			 $parentgroup,
			 $coords,
			 %{$params},
			);

    if ($itemtype eq 'curve' and $options{'-contours'}) {
      foreach my $contour (@{$options{'-contours'}}) {
	$widget->contour($item, @{$contour});
      }
    }
	
    # gestion du mode norender
    if ($options{'-texture'}) {
      my $texture = &getTexture($widget, $options{'-texture'});
      $widget->itemconfigure($item, -tile => $texture) if $texture;
    }

    if ($options{'-pattern'}) {
      my $bitmap = &getBitmap($options{'-pattern'});
      $widget->itemconfigure($item, -fillpattern => $bitmap) if $bitmap;
    }

  }


  # gestion des tags spécifiques
  if ($options{'-addtags'}) {
    my @tags = @{$options{'-addtags'}};

    my $params_tags = $params->{'-tags'};
    push (@tags, @{$params_tags}) if $params_tags;

    $widget->itemconfigure($item, -tags => \@tags);

  }


  #-------------------------------
  # TRANSFORMATIONS ZINC DE L'ITEM

  # transformation scale de l'item si nécessaire
  if ($options{'-scale'}) {
    my $scale = $options{'-scale'};
    $scale = [$scale, $scale] if (ref($scale) ne 'ARRAY');
    $widget->scale($item, @{$scale}) ;
  }

  # transformation rotate de l'item si nécessaire
  $widget->rotate($item, deg2rad($options{'-rotate'})) if ($options{'-rotate'});

  # transformation translate de l'item si nécessaire
  $widget->translate($item, @{$options{'-translate'}}) if ($options{'-translate'});


  # répétition de l'item
  if ($options{'-repeat'}) {
    push (@items, $item,
	  &repeatZincItem($widget, $item, %{$options{'-repeat'}}));
  }


  #-----------------------
  # RELIEF ET OMBRE PORTEE

  # gestion du relief
  if ($options{'-relief'}) {
    my $target = (@items) ? \@items : $item;
    push (@reliefs, &graphicItemRelief($widget, $target, %{$options{'-relief'}}));
  }

  # gestion de l'ombre portée
  if ($options{'-shadow'}) {
    my $target = (@items) ? \@items : $item;
    push (@shadows, &graphicItemShadow($widget, $target, %{$options{'-shadow'}}));
  }

  push(@items, @reliefs) if @reliefs;
  push(@items, @shadows) if @shadows;

  return (@items) ? @items : $item;

}


#-----------------------------------------------------------------------------------
# Graphics::repeatZincItem
# Duplication (clonage) d'un objet Zinc de représentation
#-----------------------------------------------------------------------------------
# paramètres :
# widget : <widget> identifiant du widget zinc
#   item : <tagOrId> identifiant de l'item source
# options :
#     -num : <n> nombre d'item total (par defaut 2)
#     -dxy : <[dx, dy]> translation entre 2 duplications (par defaut [0,0])
#   -angle : <angle> rotation entre 2 duplications
# -copytag : <sting> ajout d'un tag indexé pour chaque copie
#  -params : <hashtable> {clef => [value list]}> valeur de paramètre de chaque copie
#-----------------------------------------------------------------------------------
sub repeatZincItem {
  my ($widget, $item, %options) = @_;
  my @clones;

  # duplication d'une liste d'items -> appel récursif
  if (ref($item) eq 'ARRAY') {
    foreach my $part (@{$item}) {
      push (@clones, &repeatZincItem($widget, $part, %options));
    }

    return wantarray ? @clones : \@clones;
  }

  my $num = ($options{'-num'}) ? $options{'-num'} : 2;
  my ($dx, $dy) = (defined $options{'-dxy'}) ? @{$options{'-dxy'}} : (0, 0);
  my $angle = $options{'-angle'};
  my $params = $options{'-params'};
  my $copytag = $options{'-copytag'};
  my @tags;

  if ($copytag) {
    @tags = $widget->itemcget($item, -tags);
    unshift (@tags, $copytag."0");
    $widget->itemconfigure($item, -tags => \@tags);
  }

  for (my $i = 1; $i < $num; $i++) {
    my $clone;

    if ($copytag) {
      $tags[0] = $copytag.$i;
      $clone = $widget->clone($item, -tags => \@tags);

    } else {
      $clone = $widget->clone($item);
    }

    push(@clones, $clone);
    $widget->translate($clone, $dx*$i, $dy*$i);
    $widget->rotate($clone, deg2rad($angle*$i)) if $angle;

    if ($params) {
      while (my ($attrib, $value) = each(%{$params})) {
	$widget->itemconfigure($clone, $attrib => $value->[$i]);
      }
    }
  }

  return wantarray ? @clones : \@clones;

}


#-----------------------------------------------------------------------------------
# FONCTIONS GEOMETRIQUES
#-----------------------------------------------------------------------------------

#-----------------------------------------------------------------------------------
# Graphics::metaCoords
# retourne une liste de coordonnées en utilisant la fonction du type d'item spécifié
#-----------------------------------------------------------------------------------
# paramètres : (passés par %options)
#   -type : <string> type de primitive utilisée
# -coords : <coordsList> coordonnées nécessitée par la fonction [type]Coords
#
# les autres options spécialisées au type seront passés à la fonction [type]coords
#-----------------------------------------------------------------------------------
sub metaCoords {
  my (%options) = @_;
  my $pts;

  my $type = delete $options{'-type'};
  my $coords = delete $options{'-coords'};

  if ($type eq 'roundedrectangle') {
    $pts = &roundedRectangleCoords($coords, %options);

  } elsif ($type eq 'hippodrome') {
    $pts = &hippodromeCoords($coords, %options);

  } elsif ($type eq 'ellipse') {
    $pts = &ellipseCoords($coords, %options);

  } elsif ($type eq 'roundedcurve') {
    $pts = &roundedCurveCoords($coords, %options);

  } elsif ($type eq 'polygone') {
    $pts = &polygonCoords($coords, %options);

  } elsif ($type eq 'polyline') {
    $pts = &polylineCoords($coords, %options);

  } elsif ($type eq 'curveline') {
    $pts = &curveLineCoords($coords, %options);
  }

  return $pts;
}


#-----------------------------------------------------------------------------------
# Graphics::ZincItem2CurveCoords
# retourne une liste des coordonnées 'Curve' d'un l'item Zinc
# rectangle, arc ou curve
#-----------------------------------------------------------------------------------
# paramètres :
# widget : <widget> identifiant du widget zinc
#   item : <tagOrId> identifiant de l'item source
# options :
#     -linear : <boolean> réduction à des segments non curviligne (par défaut 0)
# -realcoords : <boolean> coordonnées à transformer dans le groupe père (par défaut 0)
#     -adjust : <boolean> ajustement de la courbe de bezier (par défaut 1)
#-----------------------------------------------------------------------------------
sub ZincItem2CurveCoords {
  my ($widget, $item, %options) = @_;

  my $itemtype = $widget->type($item);
  return unless ($itemtype);

  my $linear = $options{-linear};
  my $realcoords = $options{-realcoords};
  my $adjust = (defined $options{-adjust}) ? $options{-adjust} : 1;

  my @itemcoords = $widget->coords($item);

  my $coords;
  my @multi;

  if ($itemtype eq 'rectangle') {
    $coords = &roundedRectangleCoords(\@itemcoords, -radius => 0);

  } elsif ($itemtype eq 'arc') {
    $coords = &ellipseCoords(\@itemcoords);
    $coords = &curve2polylineCoords($coords, $adjust) if $linear;

  } elsif ($itemtype eq 'curve') {
      my $numcontours = $widget->contour($item);

      if ($numcontours < 2) {
      $coords = \@itemcoords;
      $coords = &curve2polylineCoords($coords, $adjust) if $linear;


    } else {
      if ($linear) {
	@multi = &curveItem2polylineCoords($widget, $item);

      } else {
	for (my $contour = 0; $contour < $numcontours; $contour++) {
	  my @points = $widget->coords($item, $contour);
	  push (@multi, \@points);
	}
      }

      $coords = \@multi;
    }
  }

  if ($realcoords) {
    my $parentgroup = $widget->group($item);
    if (@multi) {
      my @newcoords;
      foreach my $points (@multi) {
	my @transcoords = $widget->transform($item, $parentgroup, $points);
	push(@newcoords, \@transcoords);
      }

      $coords = \@newcoords;

    } else {
      my @transcoords = $widget->transform($item, $parentgroup, $coords);
      $coords = \@transcoords;
    }

  }

  if (@multi) {
    return (wantarray) ? @{$coords} : $coords;
  } else {
    return (wantarray) ? ($coords) : $coords;
  }
}

#-----------------------------------------------------------------------------------
# Graphics::roundedRectangleCoords
# calcul des coords du rectangle à coins arrondis
#-----------------------------------------------------------------------------------
# paramètres :
# coords : <coordsList> coordonnées bbox (haut-gauche et bas-droite) du rectangle
# options :
#  -radius : <dimension> rayon de raccord d'angle
# -corners : <booleanList> liste des raccords de sommets [0 (aucun raccord)|1] par défaut [1,1,1,1]
#-----------------------------------------------------------------------------------
sub roundedRectangleCoords {
  my ($coords, %options) = @_;
  my ($x0, $y0, $xn, $yn) = ($coords->[0]->[0], $coords->[0]->[1],
			     $coords->[1]->[0], $coords->[1]->[1]);

  my $radius = $options{'-radius'};
  my $corners = $options{'-corners'} ? $options{'-corners'} : [1, 1, 1, 1];

  # attention aux formes 'négatives'
  if ($xn < $x0) {
    my $xs = $x0;
    ($x0, $xn) = ($xn, $xs);
  }
   if ($yn < $y0) {
    my $ys = $y0;
    ($y0, $yn) = ($yn, $ys);
  }

  my $height = &_min($xn -$x0, $yn - $y0);

  if (!defined $radius) {
    $radius = int($height/10);
    $radius = 3 if $radius < 3;
  }

  if (!$radius or $radius < 2) {
    return [[$x0, $y0],[$x0, $yn],[$xn, $yn],[$xn, $y0]];

  }


  # correction de radius si necessaire
  my $max_rad = $height;
  $max_rad /= 2 if (!defined $corners);
  $radius = $max_rad if $radius > $max_rad;

  # points remarquables
  my $ptd_delta = $radius * $const_ptd_factor;
  my ($x2, $x3) = ($x0 + $radius, $xn - $radius);
  my ($x1, $x4) = ($x2 - $ptd_delta, $x3 + $ptd_delta);
  my ($y2, $y3) = ($y0 + $radius, $yn - $radius);
  my ($y1, $y4) = ($y2 - $ptd_delta, $y3 + $ptd_delta);

  # liste des 4 points sommet du rectangle : angles sans raccord circulaire
  my @angle_pts = ([$x0, $y0],[$x0, $yn],[$xn, $yn],[$xn, $y0]);

  # liste des 4 segments quadratique : raccord d'angle = radius
  my @roundeds = ([[$x2, $y0],[$x1, $y0, 'c'],[$x0, $y1, 'c'],[$x0, $y2],],
		  [[$x0, $y3],[$x0, $y4, 'c'],[$x1, $yn, 'c'],[$x2, $yn],],
		  [[$x3, $yn],[$x4, $yn, 'c'],[$xn, $y4, 'c'],[$xn, $y3],],
		  [[$xn, $y2],[$xn, $y1, 'c'],[$x4, $y0, 'c'],[$x3, $y0],]);

  my @pts = ();
  my $previous;
  for (my $i = 0; $i < 4; $i++) {
    if ($corners->[$i]) {
      if ($previous) {
	# on teste si non duplication de point
	my ($nx, $ny) = @{$roundeds[$i]->[0]};
	if ($previous->[0] == $nx and $previous->[1] == $ny) {
	  pop(@pts);
	}
      }
      push(@pts, @{$roundeds[$i]});
      $previous = $roundeds[$i]->[3];

    } else {
      push(@pts, $angle_pts[$i]);
    }
  }

  return \@pts;
}

#-----------------------------------------------------------------------------------
# Graphics::ellipseCoords
# calcul des coords d'une ellipse
#-----------------------------------------------------------------------------------
# paramètres :
# coords : <coordsList> coordonnées bbox du rectangle exinscrit
# options :
# -corners : <booleanList> liste des raccords de sommets [0 (aucun raccord)|1] par défaut [1,1,1,1]
#-----------------------------------------------------------------------------------
sub ellipseCoords {
  my ($coords, %options) = @_;
  my ($x0, $y0, $xn, $yn) = ($coords->[0]->[0], $coords->[0]->[1],
			     $coords->[1]->[0], $coords->[1]->[1]);

  my $corners = $options{'-corners'} ? $options{'-corners'} : [1, 1, 1, 1];

  # attention aux formes 'négatives'
  if ($xn < $x0) {
    my $xs = $x0;
    ($x0, $xn) = ($xn, $xs);
  }
   if ($yn < $y0) {
    my $ys = $y0;
    ($y0, $yn) = ($yn, $ys);
  }

  # points remarquables
  my $dx = ($xn - $x0)/2 * $const_ptd_factor;
  my $dy = ($yn - $y0)/2 * $const_ptd_factor;
  my ($x2, $y2) = (($x0+$xn)/2, ($y0+$yn)/2);
  my ($x1, $x3) = ($x2 - $dx, $x2 + $dx);
  my ($y1, $y3) = ($y2 - $dy, $y2 + $dy);

  # liste des 4 points sommet de l'ellipse : angles sans raccord circulaire
  my @angle_pts = ([$x0, $y0],[$x0, $yn],[$xn, $yn],[$xn, $y0]);

  # liste des 4 segments quadratique : raccord d'angle = arc d'ellipse
  my @roundeds = ([[$x2, $y0],[$x1, $y0, 'c'],[$x0, $y1, 'c'],[$x0, $y2],],
		  [[$x0, $y2],[$x0, $y3, 'c'],[$x1, $yn, 'c'],[$x2, $yn],],
		  [[$x2, $yn],[$x3, $yn, 'c'],[$xn, $y3, 'c'],[$xn, $y2],],
		  [[$xn, $y2],[$xn, $y1, 'c'],[$x3, $y0, 'c'],[$x2, $y0],]);

  my @pts = ();
  my $previous;
  for (my $i = 0; $i < 4; $i++) {
    if ($corners->[$i]) {
      if ($previous) {
	# on teste si non duplication de point
	my ($nx, $ny) = @{$roundeds[$i]->[0]};
	if ($previous->[0] == $nx and $previous->[1] == $ny) {
	  pop(@pts);
	}
      }
      push(@pts, @{$roundeds[$i]});
      $previous = $roundeds[$i]->[3];

    } else {
      push(@pts, $angle_pts[$i]);
    }
  }

  return \@pts;

}


#-----------------------------------------------------------------------------------
# Graphics::hippodromeCoords
# calcul des coords d'un hippodrome
#-----------------------------------------------------------------------------------
# paramètres :
# coords : <coordsList> coordonnées bbox du rectangle exinscrit
# options :
# -orientation : orientation forcée de l'hippodrome [horizontal|vertical]
#     -corners : liste des raccords de sommets [0|1] par défaut [1,1,1,1]
#       -trunc : troncatures [left|right|top|bottom|both]
#-----------------------------------------------------------------------------------
sub hippodromeCoords {
  my ($coords, %options) = @_;
  my ($x0, $y0, $xn, $yn) = ($coords->[0]->[0], $coords->[0]->[1],
			     $coords->[1]->[0], $coords->[1]->[1]);

  my $orientation = ($options{'-orientation'}) ? $options{'-orientation'} : 'none';

  # orientation forcée de l'hippodrome (sinon hippodrome sur le plus petit coté)
  my $height = ($orientation eq 'horizontal') ? abs($yn - $y0)
    : ($orientation eq 'vertical') ? abs($xn - $x0) : &_min(abs($xn - $x0), abs($yn - $y0));
  my $radius = $height/2;
  my $corners = [1, 1, 1, 1];

  if  ($options{'-corners'}) {
    $corners = $options{'-corners'};

  } elsif ($options{'-trunc'}) {
    my $trunc = $options{'-trunc'};
    if ($trunc eq 'both') {
      return [[$x0, $y0],[$x0, $yn],[$xn, $yn],[$xn, $y0]];

    } else {
      $corners = ($trunc eq 'left') ? [0, 0, 1, 1] :
	($trunc eq 'right') ? [1, 1, 0, 0] :
	  ($trunc eq 'top') ? [0, 1, 1, 0] : 
	    ($trunc eq 'bottom') ? [1, 0, 0, 1] : [1, 1, 1, 1];

    }
  }

  # l'hippodrome est un cas particulier de roundedRectangle
  # on retourne en passant la 'configuration' à la fonction générique roundedRectangleCoords
  return &roundedRectangleCoords($coords, -radius => $radius, -corners => $corners);
}


#-----------------------------------------------------------------------------------
# Graphics::polygonCoords
# calcul des coords d'un polygone régulier
#-----------------------------------------------------------------------------------
# paramètres :
# coords : <coords> point centre du polygone
# options :
#      -numsides : <integer> nombre de cotés
#        -radius : <dimension> rayon de définition du polygone (distance centre-sommets)
#  -inner_radius : <dimension> rayon interne (polygone type étoile)
#       -corners : <booleanList> liste des raccords de sommets [0|1] par défaut [1,1,1,1]
# -corner_radius : <dimension> rayon de raccord des cotés
#    -startangle : <angle> angle de départ en degré du polygone
#-----------------------------------------------------------------------------------
sub polygonCoords {
  my ($coords, %options) = @_;

  my $numsides = $options{'-numsides'};
  my $radius = $options{'-radius'};
  if ($numsides < 3 or !$radius) {
    print "Vous devez au moins spécifier un nombre de cotés >= 3 et un rayon...\n";
    return undef;
  }

  $coords = [0, 0] if (!defined $coords);
  my $startangle = ($options{'-startangle'}) ? $options{'-startangle'} : 0;
  my $anglestep = 360/$numsides;
  my $inner_radius = $options{'-inner_radius'};
  my @pts;

  # points du polygone
  for (my $i = 0; $i < $numsides; $i++) {
    my ($xp, $yp) = &rad_point($coords, $radius, $startangle + ($anglestep*$i));
    push(@pts, ([$xp, $yp]));

    # polygones 'étoiles'
    if ($inner_radius) {
      ($xp, $yp) = &rad_point($coords, $inner_radius, $startangle + ($anglestep*($i+ 0.5)));
      push(@pts, ([$xp, $yp]));
    }
  }


  @pts = reverse @pts;

  if ($options{'-corner_radius'}) {
    return &roundedCurveCoords(\@pts, -radius => $options{'-corner_radius'}, -corners => $options{'-corners'});
  } else {
    return \@pts;
  }
}



#-----------------------------------------------------------------------------------
# Graphics::roundedAngle
# THIS FUNCTION IS NO MORE USED, NEITHER EXPORTED
# curve d'angle avec raccord circulaire
#-----------------------------------------------------------------------------------
# paramètres :
# widget : identifiant du widget Zinc
# parentgroup : <tagOrId> identifiant de l'item group parent
# coords : <coordsList> les 3 points de l'angle
# radius : <dimension> rayon de raccord
#-----------------------------------------------------------------------------------
sub roundedAngle {
  my ($widget, $parentgroup, $coords, $radius) = @_;
  my ($pt0, $pt1, $pt2) = @{$coords};

  my ($corner_pts, $center_pts) = &roundedAngleCoords($coords, $radius);
  my ($cx0, $cy0) = @{$center_pts};

  # valeur d'angle et angle formé par la bisectrice
  my ($angle)  = &vertexAngle($pt0, $pt1, $pt2);

  $parentgroup = 1 if (!defined $parentgroup);

  $widget->add('curve', $parentgroup,
	     [$pt0,@{$corner_pts},$pt2],
	     -closed => 0, 
	     -linewidth => 1,
	     -priority => 20,
	    );

}

#-----------------------------------------------------------------------------------
# Graphics::roundedAngleCoords
# calcul des coords d'un raccord d'angle circulaire
#-----------------------------------------------------------------------------------
# le raccord circulaire de 2 droites sécantes est traditionnellement réalisé par un
# arc (conique) du cercle inscrit de rayon radius tangent à ces 2 droites
#
# Quadratique :
# une approche de cette courbe peut être réalisée simplement par le calcul de 4 points
# spécifiques qui définiront - quelle que soit la valeur de l'angle formé par les 2
# droites - le segment de raccord :
# - les 2 points de tangence au cercle inscrit seront les points de début et de fin
# du segment de raccord
# - les 2 points de controle seront situés chacun sur le vecteur reliant le point de
# tangence au sommet de l'angle (point secant des 2 droites)
# leur position sur ce vecteur peut être simplifiée comme suit :
# - à un facteur de 0.5523 de la distance au sommet pour un angle >= 90° et <= 270°
# - à une 'réduction' de ce point vers le point de tangence pour les angles limites
# de 90° vers 0° et de 270° vers 360°
# ce facteur sera légérement modulé pour recouvrir plus précisement l'arc correspondant
#-----------------------------------------------------------------------------------
# coords : <coordsList> les 3 points de l'angle
# radius : <dimension> rayon de raccord
#-----------------------------------------------------------------------------------
sub roundedAngleCoords {
  my ($coords, $radius) = @_;
  my ($pt0, $pt1, $pt2) = @{$coords};

  # valeur d'angle et angle formé par la bisectrice
  my ($angle, $bisecangle)  = &vertexAngle($pt0, $pt1, $pt2);

  # distance au centre du cercle inscrit : rayon/sinus demi-angle
  my $sin = sin(deg2rad($angle/2));
  my $delta = ($sin) ? abs($radius / $sin) : $radius;

  # point centre du cercle inscrit de rayon $radius
  my $refangle = ($angle < 180) ? $bisecangle+90 : $bisecangle-90;
  my ($cx0, $cy0) = rad_point($pt1, $delta, $refangle);

  # points de tangeance : pts perpendiculaires du centre aux 2 droites
  my ($px1, $py1) = &perpendicularPoint([$cx0, $cy0], [$pt0, $pt1]);
  my ($px2, $py2) = &perpendicularPoint([$cx0, $cy0], [$pt1, $pt2]);

  # point de controle de la quadratique
  # facteur de positionnement sur le vecteur pt.tangence, sommet
  my $ptd_factor =  $const_ptd_factor;
  if ($angle < 90 or $angle > 270) {
    my $diffangle = ($angle < 90) ? $angle : 360 - $angle;
    $ptd_factor -= (((90 - $diffangle)/90) * ($ptd_factor/4)) if $diffangle > 15 ;
    $ptd_factor = ($diffangle/90) * ($ptd_factor + ((1 - $ptd_factor) * (90 - $diffangle)/90));
  } else {
    my $diffangle = abs(180 - $angle);
    $ptd_factor += (((90 - $diffangle)/90) * ($ptd_factor/3)) if $diffangle > 15;
  }

  # delta xy aux pts de tangence
  my ($d1x, $d1y) = (($pt1->[0] - $px1) * $ptd_factor, ($pt1->[1] - $py1) *  $ptd_factor);
  my ($d2x, $d2y) = (($pt1->[0] - $px2) * $ptd_factor, ($pt1->[1] - $py2) *  $ptd_factor);

  # les 4 points de l'arc 'quadratique'
  my $corner_pts = [[$px1, $py1],[$px1+$d1x, $py1+$d1y, 'c'],
		    [$px2+$d2x, $py2+$d2y, 'c'],[$px2, $py2]];


  # retourne le segment de quadratique et le centre du cercle inscrit
  return ($corner_pts, [$cx0, $cy0]);

}


#-----------------------------------------------------------------------------------
# Graphics::roundedCurveCoords
# retourne les coordonnées d'une curve à coins arrondis
#-----------------------------------------------------------------------------------
# paramètres :
# coords : <coordsList> liste de coordonnées des points de la curve
# options :
#  -radius : <dimension> rayon de raccord d'angle
# -corners : <booleanList> liste des raccords de sommets [0|1] par défaut [1,1,1,1]
#-----------------------------------------------------------------------------------
sub roundedCurveCoords {
  my ($coords, %options) = @_;
  my $numfaces = scalar(@{$coords});
  my @curve_pts;

  my $radius = (defined $options{'-radius'}) ? $options{'-radius'} : 0;
  my $corners = $options{'-corners'};

  for (my $index = 0; $index < $numfaces; $index++) {
    if ($corners and !$corners->[$index]) {
      push(@curve_pts, $coords->[$index]);

    } else {
      my $prev = ($index) ? $index - 1 : $numfaces - 1;
      my $next = ($index > $numfaces - 2) ? 0 : $index + 1;
      my $anglecoords = [$coords->[$prev], $coords->[$index], $coords->[$next]];

      my ($quad_pts) = &roundedAngleCoords($anglecoords, $radius);
      push(@curve_pts, @{$quad_pts});
    }
  }

  return \@curve_pts;

}


#-----------------------------------------------------------------------------------
# Graphics::polylineCoords
# retourne les coordonnées d'une polyline
#-----------------------------------------------------------------------------------
# paramètres :
# coords : <coordsList> liste de coordonnées des sommets de la polyline
# options :
#  -radius : <dimension> rayon global de raccord d'angle
# -corners : <booleanList> liste des raccords de sommets [0|1] par défaut [1,1,1,1],
# -corners_radius : <dimensionList> liste des rayons de raccords de sommets
#-----------------------------------------------------------------------------------
sub polylineCoords {
  my ($coords, %options) = @_;
  my $numfaces = scalar(@{$coords});
  my @curve_pts;

  my $radius = ($options{'-radius'}) ? $options{'-radius'} : 0;
  my $corners_radius = $options{'-corners_radius'};
  my $corners = ($corners_radius) ? $corners_radius : $options{'-corners'};

  for (my $index = 0; $index < $numfaces; $index++) {
    if ($corners and !$corners->[$index]) {
      push(@curve_pts, $coords->[$index]);

    } else {
      my $prev = ($index) ? $index - 1 : $numfaces - 1;
      my $next = ($index > $numfaces - 2) ? 0 : $index + 1;
      my $anglecoords = [$coords->[$prev], $coords->[$index], $coords->[$next]];

      my $rad = ($corners_radius) ? $corners_radius->[$index] : $radius;
      my ($quad_pts) = &roundedAngleCoords($anglecoords, $rad);
      push(@curve_pts, @{$quad_pts});
    }
  }

  return \@curve_pts;

}

#-----------------------------------------------------------------------------------
# Graphics::pathLineCoords
# retourne les coordonnées d'une pathLine
#-----------------------------------------------------------------------------------
# paramètres :
# coords : <coordsList> liste de coordonnées des points du path
# options :
#    -closed : <boolean> ligne fermée
#  -shifting : <out|center|in> sens de décalage du path (par défaut center)
# -linewidth : <dimension> epaisseur de la ligne
#-----------------------------------------------------------------------------------
sub pathLineCoords {
  my ($coords, %options) = @_;
  my $numfaces = scalar(@{$coords});
  my @pts;

  my $closed = $options{'-closed'};
  my $linewidth = ($options{'-linewidth'}) ? $options{'-linewidth'} : 2;
  my $shifting = ($options{'-shifting'}) ? $options{'-shifting'} : 'center';

  return undef if (!$numfaces or $linewidth < 2);

  my $previous = ($closed) ? $coords->[$numfaces - 1] : undef;
  my $next = $coords->[1];
  $linewidth /= 2 if ($shifting eq 'center');

  for (my $i = 0; $i < $numfaces; $i++) {
    my $pt = $coords->[$i];

    if (!$previous) {
      # extrémité de curve sans raccord -> angle plat
      $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])];
    }

    my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next);

    # distance au centre du cercle inscrit : rayon/sinus demi-angle
    my $sin = sin(deg2rad($angle/2));
    my $delta = ($sin) ? abs($linewidth / $sin) : $linewidth;

    if ($shifting eq 'out' or $shifting eq 'in') {
      my $adding = ($shifting eq 'out') ? -90 : 90;
      push (@pts,  &rad_point($pt, $delta, $bisecangle + $adding));
      push (@pts,  @{$pt});

    } else {
      push (@pts,  &rad_point($pt, $delta, $bisecangle-90));
      push (@pts,  &rad_point($pt, $delta, $bisecangle+90));

    }

    if ($i == $numfaces - 2) {
      $next = ($closed) ? $coords->[0] :
	[$coords->[$i+1]->[0] + ($coords->[$i+1]->[0] - $pt->[0]), $coords->[$i+1]->[1] + ($coords->[$i+1]->[1] - $pt->[1])];
    } else {
      $next = $coords->[$i+2];
    }

    $previous = $coords->[$i];
  }

  if ($closed) {
    push (@pts, ($pts[0], $pts[1], $pts[2], $pts[3]));
  }

  return \@pts;
}

#-----------------------------------------------------------------------------------
# Graphics::curveLineCoords
# retourne les coordonnées d'une curveLine
#-----------------------------------------------------------------------------------
# paramètres :
# coords : <coordsList> liste de coordonnées des points de la ligne
# options :
#    -closed : <boolean> ligne fermée
#  -shifting : <out|center|in> sens de décalage du contour (par défaut center)
# -linewidth : <dimension> epaisseur de la ligne
#-----------------------------------------------------------------------------------
sub curveLineCoords {
  my ($coords, %options) = @_;
  my $numfaces = scalar(@{$coords});
  my @gopts;
  my @backpts;
  my @pts;

  my $closed = $options{'-closed'};
  my $linewidth = (defined $options{'-linewidth'}) ? $options{'-linewidth'} : 2;
  my $shifting = ($options{'-shifting'}) ? $options{'-shifting'} : 'center';

  return undef if (!$numfaces or $linewidth < 2);

  my $previous = ($closed) ? $coords->[$numfaces - 1] : undef;
  my $next = $coords->[1];
  $linewidth /= 2 if ($shifting eq 'center');

  for (my $i = 0; $i < $numfaces; $i++) {
    my $pt = $coords->[$i];

    if (!$previous) {
      # extrémité de curve sans raccord -> angle plat
      $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])];
    }

    my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next);

    # distance au centre du cercle inscrit : rayon/sinus demi-angle
    my $sin = sin(deg2rad($angle/2));
    my $delta = ($sin) ? abs($linewidth / $sin) : $linewidth;

    if ($shifting eq 'out' or $shifting eq 'in') {
      my $adding = ($shifting eq 'out') ? -90 : 90;
      push (@pts,  &rad_point($pt, $delta, $bisecangle + $adding));
      push (@pts,  @{$pt});

    } else {
      @pts = &rad_point($pt, $delta, $bisecangle+90);
      push (@gopts, \@pts);
      @pts = &rad_point($pt, $delta, $bisecangle-90);
      unshift (@backpts, \@pts);
    }

    if ($i == $numfaces - 2) {
      $next = ($closed) ? $coords->[0] :
	[$coords->[$i+1]->[0] + ($coords->[$i+1]->[0] - $pt->[0]), $coords->[$i+1]->[1] + ($coords->[$i+1]->[1] - $pt->[1])];
    } else {
      $next = $coords->[$i+2];
    }

    $previous = $coords->[$i];
  }

  push(@gopts, @backpts);

  if ($closed) {
    push (@gopts, ($gopts[0], $gopts[1]));
  }

  return \@gopts;
}


#-----------------------------------------------------------------------------------
# Graphics::shiftPathCoords
# retourne les coordonnées d'un décalage de path
#-----------------------------------------------------------------------------------
# paramètres :
# coords : <coordsList> liste de coordonnées des points du path
# options :
#   -closed : <boolean> ligne fermée
# -shifting : <'out'|'in'> sens de décalage du path (par défaut out)
#    -width : <dimension> largeur de décalage (par défaut 1)
#-----------------------------------------------------------------------------------
sub shiftPathCoords {
  my ($coords, %options) = @_;
  my $numfaces = scalar(@{$coords});

  my $closed = $options{'-closed'};
  my $width = (defined $options{'-width'}) ? $options{'-width'} : 1;
  my $shifting = ($options{'-shifting'}) ? $options{'-shifting'} : 'out';

  return $coords if (!$numfaces or !$width);

  my @pts;

  my $previous = ($closed) ? $coords->[$numfaces - 1] : undef;
  my $next = $coords->[1];

  for (my $i = 0; $i < $numfaces; $i++) {
    my $pt = $coords->[$i];

    if (!$previous) {
      # extrémité de curve sans raccord -> angle plat
      $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])];
    }

    my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next);

    # distance au centre du cercle inscrit : rayon/sinus demi-angle
    my $sin = sin(deg2rad($angle/2));
    my $delta = ($sin) ? abs($width / $sin) : $width;

    my $adding = ($shifting eq 'out') ? -90 : 90;
    my ($x, $y) = &rad_point($pt, $delta, $bisecangle + $adding);
    push (@pts,  [$x, $y]);


    if ($i > $numfaces - 3) {
      my $j = $numfaces - 1;
      $next = ($closed) ? $coords->[0] :
	[$pt->[0] + ($pt->[0] - $previous->[0]), $pt->[1] + ($pt->[1] - $previous->[1])];

    } else {
      $next = $coords->[$i+2];
    }

    $previous = $coords->[$i];
  }

  return \@pts;
}

#-----------------------------------------------------------------------------------
# Graphics::perpendicularPoint
# retourne les coordonnées du point perpendiculaire abaissé d'un point sur une ligne
#-----------------------------------------------------------------------------------
# paramètres :
# point : <coords> coordonnées du point de référence
#  line : <coordsList> coordonnées des 2 points de la ligne de référence
#-----------------------------------------------------------------------------------
sub perpendicularPoint {
  my ($point, $line) = @_;
  my ($p1, $p2) = @{$line};

  # cas partiuculier de lignes ortho.
  my $min_dist = .01;
  if (abs($p2->[1] - $p1->[1]) < $min_dist) {
    # la ligne de référence est horizontale
    return ($point->[0], $p1->[1]);

  } elsif (abs($p2->[0] - $p1->[0]) < $min_dist) {
    # la ligne de référence est verticale
    return ($p1->[0], $point->[1]);
  }

  my $a1 = ($p2->[1] - $p1->[1]) / ($p2->[0] - $p1->[0]);
  my $b1 = $p1->[1] - ($a1 * $p1->[0]);

  my $a2 = -1.0 / $a1;
  my $b2 = $point->[1] - ($a2 * $point->[0]);

  my $x = ($b2 - $b1) / ($a1 - $a2);
  my $y = ($a1 * $x) + $b1;

  return ($x, $y);

}


#-----------------------------------------------------------------------------------
# Graphics::lineAngle
# retourne l'angle d'un point par rapport à un centre de référence
#-----------------------------------------------------------------------------------
# paramètres :
# startpoint : <coords> coordonnées du point de départ du segment
#   endpoint : <coords> coordonnées du point d'extremité du segment
#-----------------------------------------------------------------------------------
sub lineAngle {
  my ($startpoint, $endpoint) = @_;
  my $angle = atan2($endpoint->[1] - $startpoint->[1], $endpoint->[0] - $startpoint->[0]);

  $angle += pi/2;
  $angle *= 180/pi;
  $angle += 360  if ($angle < 0);

  return $angle;

}


#-----------------------------------------------------------------------------------
# Graphics::lineNormal
# retourne la valeur d'angle perpendiculaire à une ligne
#-----------------------------------------------------------------------------------
# paramètres :
# startpoint : <coords> coordonnées du point de départ du segment
#   endpoint : <coords> coordonnées du point d'extremité du segment
#-----------------------------------------------------------------------------------
sub lineNormal {
  my ($startpoint, $endpoint) = @_;
  my $angle = &lineAngle($startpoint, $endpoint) + 90;

  $angle -= 360  if ($angle > 360);
  return $angle;

}



#-----------------------------------------------------------------------------------
# Graphics::vertexAngle
# retourne la valeur de l'angle formée par 3 points
# ainsi que l'angle de la bisectrice
#-----------------------------------------------------------------------------------
# paramètres :
# pt0 : <coords> coordonnées du premier point de définition de l'angle
# pt1 : <coords> coordonnées du deuxième point de définition de l'angle
# pt2 : <coords> coordonnées du troisième point de définition de l'angle
#-----------------------------------------------------------------------------------
sub vertexAngle {
  my ($pt0, $pt1, $pt2) = @_;
  my $angle1 = &lineAngle($pt0, $pt1);
  my $angle2 = &lineAngle($pt2, $pt1);

  $angle2 += 360 if $angle2 < $angle1;
  my $alpha = $angle2 - $angle1;
  my $bisectrice = $angle1 + ($alpha/2);

  return ($alpha, $bisectrice);
}


#-----------------------------------------------------------------------------------
# Graphics::arc_pts
# calcul des points constitutif d'un arc
#-----------------------------------------------------------------------------------
# paramètres :
#  center : <coordonnées> centre de l'arc,
#  radius : <dimension> rayon de l'arc,
# options :
#  -angle : <angle> angle de départ en degré de l'arc (par défaut 0)
# -extent : <angle> delta angulaire en degré de l'arc (par défaut 360),
#   -step : <dimension> pas de progresion en degré (par défaut 10)
#-----------------------------------------------------------------------------------
sub arc_pts {
    my ($center, $radius, %options) = @_;
    return unless ($radius);

    $center = [0, 0] if (!defined $center);
    my $angle = (defined $options{'-angle'}) ? $options{'-angle'} : 0;
    my $extent = (defined $options{'-extent'}) ? $options{'-extent'} : 360;
    my $step = (defined $options{'-step'}) ? $options{'-step'} : 10;
    my @pts = ();

    if ($extent > 0) {
	for (my $alpha = $angle; $alpha <= ($angle + $extent); $alpha += $step) {
	    my ($xn, $yn) = &rad_point($center, $radius,$alpha);
	    push (@pts, ([$xn, $yn]));
	}
    } else {
	for (my $alpha = $angle; $alpha >= ($angle + $extent); $alpha += $step) {
	    push (@pts, &rad_point($center, $radius, $alpha));
	}
    }

    return @pts;
}


#-----------------------------------------------------------------------------------
# Graphics::rad_point
# retourne le point circulaire défini par centre-rayon-angle
#-----------------------------------------------------------------------------------
# paramètres :
# center : <coordonnée> coordonnée [x,y] du centre de l'arc,
# radius : <dimension> rayon de l'arc,
#  angle : <angle> angle du point de circonférence avec le centre du cercle
#-----------------------------------------------------------------------------------
sub rad_point {
    my ($center, $radius, $angle) = @_;
    my $alpha = deg2rad($angle);

    my $xpt = $center->[0] + ($radius * cos($alpha));
    my $ypt = $center->[1] + ($radius * sin($alpha));

    return ($xpt, $ypt);
}


#-----------------------------------------------------------------------------------
# Graphics::curveItem2polylineCoords
# Conversion des coordonnées ZnItem curve (multicontours) en coordonnées polyline(s)
#-----------------------------------------------------------------------------------
# paramètres :
# widget : <widget> identifiant du widget zinc
#   item : <tagOrId> identifiant de l'item source
# options :
# -tunits : <integer> nombre pas de division des segments bezier (par défaut 20)
# -adjust : <boolean> ajustement de la courbe de bezier (par défaut 1)
#-----------------------------------------------------------------------------------
sub curveItem2polylineCoords {
  my ($widget, $item, %options) = @_;
  return unless ($widget and $widget->type($item));

  my @coords;
  my $numcontours = $widget->contour($item);
  my $parentgroup = $widget->group($item);

  for (my $contour = 0; $contour < $numcontours; $contour++) {
    my @points = $widget->coords($item, $contour);
    my @contourcoords = &curve2polylineCoords(\@points, %options);

    push(@coords, \@contourcoords);

  }

  return wantarray ? @coords : \@coords;
}

#-----------------------------------------------------------------------------------
# Graphics::curve2polylineCoords
# Conversion curve -> polygone
#-----------------------------------------------------------------------------------
# paramètres :
# points : <coordsList> liste des coordonnées curve à transformer
# options :
# -tunits : <integer> nombre pas de division des segments bezier (par défaut 20)
# -adjust : <boolean> ajustement de la courbe de bezier (par défaut 1)
#-----------------------------------------------------------------------------------
sub curve2polylineCoords {
  my ($points, %options) = @_;

  my $tunits = ($options{'-tunits'}) ? $options{'-tunits'} : 20;
  my $adjust = (defined $options{'-adjust'}) ? $options{'-adjust'} : 1;

  my @poly;
  my $previous;
  my @bseg;
  my $numseg = 0;
  my $prevtype;

  foreach my $point (@{$points}) {
    my ($x, $y, $c) = @{$point};
    if ($c eq 'c') {
      push(@bseg, $previous) if (!@bseg);
      push(@bseg, $point);

    } else {
      if (@bseg) {
	push(@bseg, $point);

	if ($adjust) {
	  my @pts = &bezierCompute(\@bseg, -skipend => 1);
	  shift @pts;
	  shift @pts;
	  push(@poly, @pts);

	} else {
	  my @pts = &bezierSegment(\@bseg, -tunits => $tunits, -skipend => 1);
	  shift @pts;
	  shift @pts;
	  push(@poly, @pts);

	}

	@bseg = ();
	$numseg++;
	$prevtype = 'bseg';

      } else {
	push(@poly, ([$x, $y]));
	$prevtype = 'line';
      }
    }

    $previous = $point;
  }


  return wantarray ? @poly : \@poly;
}


#-----------------------------------------------------------------------------------
# Graphics::buildTabBoxItem
# construit les items de représentations Zinc d'une boite à onglets
#-----------------------------------------------------------------------------------
# paramètres :
#      widget : <widget> identifiant du widget zinc
# parentgroup : <tagOrId> identifiant de l'item group parent
#
#    options :
#     -coords : <coordsList> coordonnées haut-gauche et bas-droite du rectangle
#               englobant du TabBox
#     -params : <hastable> arguments spécifiques des items curve à passer au widget
#    -texture : <imagefile> ajout d'une texture aux items curve
#  -tabtitles : <hashtable> table de hash de définition des titres onglets
#  -pageitems : <hashtable> table de hash de définition des pages internes
#     -relief : <hashtable> table de hash de définition du relief de forme
#
# (options de construction géometrique passées à tabBoxCoords)
#  -numpages : <integer> nombre de pages (onglets) de la boite
#    -anchor : <'n'|'e'|'s'|'w'> ancrage (positionnement) de la ligne d'onglets
# -alignment : <'left'|'center'|'right'> alignement des onglets sur le coté d'ancrage
#  -tabwidth : <'auto'>|<dimension>|<dimensionList> : largeur des onglets
#              'auto' largeur répartie, les largeurs sont auto-ajustée si besoin.
# -tabheight : <'auto'>|<dimension> : hauteur des onglets
#  -tabshift : <'auto'>|<dimension> offset de 'biseau' entre base et haut de l'onglet (défaut auto)
#    -radius : <dimension> rayon des arrondis d'angle
#   -overlap : <'auto'>|<dimension> offset de recouvrement/séparation entre onglets
#   -corners : <booleanList> liste 'spécifique' des raccords de sommets [0|1]
#-----------------------------------------------------------------------------------
sub buildTabBoxItem {
  my ($widget, $parentgroup, %options) = @_;
  my $coords = $options{'-coords'};
  my $params = $options{'-params'};
  my @tags = @{$params->{'-tags'}};
  my $texture;

  if ($options{'-texture'}) {
    $texture = &getTexture($widget, $options{'-texture'});
  }

  my $titlestyle = $options{'-tabtitles'};
  my $titles = ($titlestyle) ? $titlestyle->{'-text'} : undef ;

  return undef if (!$coords);

  my @tabs;
  my ($shapes, $tcoords, $invert) = &tabBoxCoords($coords, %options);
  my $k = ($invert) ? scalar @{$shapes} : -1;
  foreach my $shape (reverse @{$shapes}) {
    $k += ($invert) ? -1 : +1;
    my $group = $widget->add('group', $parentgroup);
    $params->{'-tags'} = [@tags, $k, 'intercalaire'];
    my $form = $widget->add('curve', $group, $shape, %{$params});
    $widget->itemconfigure($form, -tile => $texture) if $texture;

    if ($options{'-relief'}) {
      &graphicItemRelief($widget, $form, %{$options{'-relief'}});
    }

    if ($options{'-page'}) {
      my $page = &buildZincItem($widget, $group, %{$options{'-page'}});
    }	

    if ($titles) {
      my $tindex = ($invert) ? $k : $#{$shapes} - $k;
      $titlestyle->{'-itemtype'} = 'text';
      $titlestyle->{'-coords'} = $tcoords->[$tindex];
      $titlestyle->{'-params'}->{'-text'} = $titles->[$tindex],;
      $titlestyle->{'-params'}->{'-tags'} = [@tags, $tindex, 'titre'];
      &buildZincItem($widget, $group, %{$titlestyle});

    }


  }

  return @tabs;
}


#-----------------------------------------------------------------------------------
# tabBoxCoords
# Calcul des shapes de boites à onglets
#-----------------------------------------------------------------------------------
# paramètres :
# coords : <coordList> coordonnées haut-gauche bas-droite du rectangle englobant 
#          de la tabbox
# options
#  -numpages : <integer> nombre de pages (onglets) de la boite
#    -anchor : <'n'|'e'|'s'|'w'> ancrage (positionnement) de la ligne d'onglets
# -alignment : <'left'|'center'|'right'> alignement des onglets sur le coté d'ancrage
#  -tabwidth : <'auto'>|<dimension>|<dimensionList> : largeur des onglets
#              'auto' largeur répartie, les largeurs sont auto-ajustée si besoin.
# -tabheight : <'auto'>|<dimension> : hauteur des onglets
#  -tabshift : <'auto'>|<dimension> offset de 'biseau' entre base et haut de l'onglet (défaut auto)
#    -radius : <dimension> rayon des arrondis d'angle
#   -overlap : <'auto'>|<dimension> offset de recouvrement/séparation entre onglets
#   -corners : <booleanList> liste 'spécifique' des raccords de sommets [0|1]
#-----------------------------------------------------------------------------------
sub tabBoxCoords {
  my ($coords, %options) = @_;

  my ($x0, $y0, $xn, $yn) = (@{$coords->[0]}, @{$coords->[1]});
  my (@shapes, @titles_coords);
  my $inverse;

  my @options = keys(%options);
  my $numpages = $options{'-numpages'};

  if (!defined $x0 or !defined $y0 or !defined $xn or !defined $yn or !$numpages) {
    print "Vous devez au minimum spécifier le rectangle englobant et le nombre de pages\n";
    return undef;

  }

  my $anchor = ($options{'-anchor'}) ? $options{'-anchor'} : 'n';
  my $alignment = ($options{'-alignment'}) ? $options{'-alignment'} : 'left';
  my $len = ($options{'-tabwidth'}) ? $options{'-tabwidth'} : 'auto';
  my $thick = ($options{'-tabheight'}) ? $options{'-tabheight'} : 'auto';
  my $biso = ($options{'-tabshift'}) ? $options{'-tabshift'} : 'auto';
  my $radius = ($options{'-radius'}) ? $options{'-radius'} : 0;
  my $overlap = ($options{'-overlap'}) ? $options{'-overlap'} : 0;
  my $corners = $options{'-corners'};
  my $orientation = ($anchor eq 'n' or $anchor eq 's') ? 'horizontal' : 'vertical';
  my $maxwidth = ($orientation eq 'horizontal') ? ($xn - $x0) : ($yn - $y0);
  my $tabswidth = 0;
  my $align = 1;

  if ($len eq 'auto') {
    $tabswidth = $maxwidth;
    $len = ($tabswidth + ($overlap * ($numpages - 1)))/$numpages;

  } else {
    if (ref($len) eq 'ARRAY') {
      foreach my $w (@{$len}) {
	$tabswidth += ($w - $overlap);
      }
      $tabswidth += $overlap;
    } else {
      $tabswidth = ($len * $numpages) - ($overlap * ($numpages - 1));
    }

    if ($tabswidth > $maxwidth) {
      $tabswidth = $maxwidth;
      $len = ($tabswidth + ($overlap * ($numpages - 1)))/$numpages;
    }

    $align = 0 if ($alignment eq 'center' and (($maxwidth - $tabswidth) > $radius));
  }


  if ($thick eq 'auto') {
    $thick = ($orientation eq 'horizontal') ? int(($yn - $y0)/10) : int(($xn - $y0)/10);
    $thick = 10 if ($thick < 10);
    $thick = 40 if ($thick > 40);
  }

  if ($biso eq 'auto') {
    $biso = int($thick/2);
  }

  if (($alignment eq 'right' and $anchor ne 'w') or
      ($anchor eq 'w' and $alignment ne 'right')) {

    if (ref($len) eq 'ARRAY') {
      for (my $p = 0; $p < $numpages; $p++) {
	$len->[$p] *= -1;
      }
    } else {
      $len *= -1;
    }
    $biso *= -1;
    $overlap *= -1;
  }

  my ($biso1, $biso2) = ($alignment eq 'center') ? ($biso/2, $biso/2) : (0, $biso);

  my (@cadre, @tabdxy);
  my ($xref, $yref);
  if ($orientation eq 'vertical') {
    $thick *= -1 if ($anchor eq 'w');
    my ($startx, $endx) = ($anchor eq 'w') ? ($x0, $xn) : ($xn, $x0);
    my ($starty, $endy) = (($anchor eq 'w' and $alignment ne 'right') or 
			   ($anchor eq 'e' and $alignment eq 'right')) ? 
			     ($yn, $y0) : ($y0, $yn);

    $xref = $startx - $thick;
    $yref = $starty;
    if  ($alignment eq 'center') {
      my $ratio = ($anchor eq 'w') ? -2 : 2;
      $yref += (($maxwidth - $tabswidth)/$ratio);
    }

    @cadre = ([$xref, $endy], [$endx, $endy], [$endx, $starty], [$xref, $starty]);

    # flag de retournement de la liste des pts de curve si nécessaire -> sens anti-horaire
    $inverse = ($alignment ne 'right');

  } else {
    $thick *= -1 if ($anchor eq 's');
    my ($startx, $endx) = ($alignment eq 'right') ? ($xn, $x0) : ($x0, $xn);
    my ($starty, $endy) = ($anchor eq 's') ? ($yn, $y0) : ($y0, $yn);


    $yref = $starty + $thick;
    $xref = ($alignment eq 'center') ? $x0 + (($maxwidth - $tabswidth)/2) : $startx;

    @cadre = ([$endx, $yref], [$endx, $endy], [$startx, $endy], [$startx, $yref]);

    # flag de retournement de la liste des pts de curve si nécessaire -> sens anti-horaire
    $inverse = (($anchor eq 'n' and $alignment ne 'right') or ($anchor eq 's' and $alignment eq 'right'));
  }

  for (my $i = 0; $i < $numpages; $i++) {
    my @pts = ();

    # décrochage onglet
    #push (@pts, ([$xref, $yref])) if $i > 0;

    # cadre
    push (@pts, @cadre);

    # points onglets
    push (@pts, ([$xref, $yref])) if ($i > 0 or !$align);

    my $tw = (ref($len) eq 'ARRAY') ? $len->[$i] : $len;
    @tabdxy = ($orientation eq 'vertical') ?
      ([$thick, $biso1],[$thick, $tw - $biso2],[0, $tw]) : ([$biso1, -$thick],[$tw - $biso2, -$thick],[$tw, 0]);
    foreach my $dxy (@tabdxy) {
      push (@pts, ([$xref + $dxy->[0], $yref + $dxy->[1]]));
    }

    if ($radius) {
      if (!defined $options{'-corners'}) {
	$corners = ($i > 0 or !$align) ? [0, 1, 1, 0, 0, 1, 1, 0] : [0, 1, 1, 0, 1, 1, 0, 0, 0];
      }
      my $curvepts = &roundedCurveCoords(\@pts, -radius => $radius, -corners => $corners);
      @{$curvepts} = reverse @{$curvepts} if ($inverse);
      push (@shapes, $curvepts);
    } else {
      @pts = reverse @pts if ($inverse);
      push (@shapes, \@pts);
    }

    if ($orientation eq 'horizontal') {
      push (@titles_coords, [$xref + ($tw - ($biso2 - $biso1))/2, $yref - ($thick/2)]);
      $xref += ($tw - $overlap);

    } else {
      push (@titles_coords, [$xref + ($thick/2), $yref + ($len - (($biso2 - $biso1)/2))/2]);
      $yref += ($len - $overlap);
    }

  }

  return (\@shapes, \@titles_coords, $inverse);

}


#-----------------------------------------------------------------------------------
# Graphics::graphicItemRelief
# construit un relief à l'item Zinc en utilisant des items Triangles
#-----------------------------------------------------------------------------------
# paramètres :
#  widget : <widget> identifiant du widget zinc
#    item : <tagOrId> identifiant de l'item zinc
# options : <hash> table d'options
#     -closed : <boolean> le relief assure la fermeture de forme (défaut 1)
#     -profil : <'rounded'|'flat'> type de profil (defaut 'rounded')
#     -relief : <'raised'|'sunken'> (défaut 'raised')
#       -side : <'inside'|'outside'> relief interne ou externe à la forme (défaut 'inside')
#      -color : <color> couleur du relief (défaut couleur de la forme)
#   -smoothed : <boolean> facettes relief lissées ou non (défaut 1)
# -lightangle : <angle> angle d'éclairage (défaut valeur générale widget)
#      -width : <dimension> 'épaisseur' du relief en pixel
#       -fine : <boolean> mode précision courbe de bezier (défaut 0 : auto-ajustée)
#-----------------------------------------------------------------------------------
sub graphicItemRelief {
  my ($widget, $item, %options) = @_;
  my @items;

  # relief d'une liste d'items -> appel récursif
  if (ref($item) eq 'ARRAY') {
    foreach my $part (@{$item}) {
      push(@items, &graphicItemRelief($widget, $part, %options));
    }

  } else {
    my $itemtype = $widget->type($item);

    return unless ($itemtype);

    my $parentgroup = $widget->group($item);
    my $priority = (defined $options{'-priority'}) ? $options{'-priority'} :
      $widget->itemcget($item, -priority)+1;

    # coords transformés (polyline) de l'item
    my $adjust = !$options{'-fine'};
    foreach my $coords (&ZincItem2CurveCoords($widget, $item, -linear => 1,
					      -realcoords => 1,-adjust => $adjust)) {
      my ($pts, $colors) = &polylineReliefParams($widget, $item, $coords, %options);

      push(@items, $widget->add('triangles', $parentgroup, $pts,
				-priority => $priority,
				-colors => $colors));
    }


    # renforcement du contour
    if ($widget->itemcget($item, -linewidth)) {
      push(@items, $widget->clone($item, -filled => 0, -priority => $priority+1));
    }
  }

  return \@items;
}


#-----------------------------------------------------------------------------------
# Graphics::polylineReliefParams
# retourne la liste des points et des couleurs nécessaires à la construction
# de l'item Triangles du relief
#-----------------------------------------------------------------------------------
# paramètres :
#  widget : <widget> identifiant widget Zinc
#    item : <tagOrId> identifiant item Zinc
# options : <hash> table d'options
#     -closed : <boolean> le relief assure la fermeture de forme (défaut 1)
#     -profil : <'rounded'|'flat'> type de profil (defaut 'rounded')
#     -relief : <'raised'|'sunken'> (défaut 'raised')
#       -side : <'inside'|'outside'> relief interne ou externe à la forme (défaut 'inside')
#      -color : <color> couleur du relief (défaut couleur de la forme)
#   -smoothed : <boolean> facettes relief lissées ou non (défaut 1)
# -lightangle : <angle> angle d'éclairage (défaut valeur générale widget)
#      -width : <dimension> 'épaisseur' du relief en pixel
#-----------------------------------------------------------------------------------
sub polylineReliefParams {
  my ($widget, $item, $coords, %options) = @_;

  my $closed = (defined $options{'-closed'}) ? $options{'-closed'} : 1;
  my $profil = ($options{'-profil'}) ? $options{'-profil'} : 'rounded';
  my $relief = ($options{'-relief'}) ? $options{'-relief'} : 'raised';
  my $side = ($options{'-side'}) ? $options{'-side'} : 'inside';
  my $basiccolor = ($options{'-color'}) ? $options{'-color'} : &zincItemPredominantColor($widget, $item);
  my $smoothed = (defined $options{'-smooth'}) ? $options{'-smooth'} : 1;
  my $lightangle = (defined $options{'-lightangle'}) ? $options{'-lightangle'}
    : $widget->cget('-lightangle');

  my $width = $options{'-width'};
  if (!$width or $width < 1) {
    my ($x0, $y0, $x1, $y1) = $widget->bbox($item);
    $width = &_min($x1 -$x0, $y1 - $y0)/10;
    $width = 2 if ($width < 2);
  }

  my $numfaces = scalar(@{$coords});
  my $previous = ($closed) ? $coords->[$numfaces - 1] : undef;
  my $next = $coords->[1];

  my @pts;
  my @colors;
  my $alpha = 100;
  if ($basiccolor =~ /;/) {
    ($basiccolor, $alpha) = split /;/, $basiccolor;

  }

  $alpha /= 2 if (!($options{'-color'} =~ /;/) and $profil eq 'flat');

  my $reliefalphas = ($profil eq 'rounded') ? [0,$alpha] : [$alpha, $alpha];

  for (my $i = 0; $i < $numfaces; $i++) {
    my $pt = $coords->[$i];

    if (!$previous) {
      # extrémité de curve sans raccord -> angle plat
      $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])];
    }

    my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next);

    # distance au centre du cercle inscrit : rayon/sinus demi-angle
    my $sin = sin(deg2rad($angle/2));
    my $delta = ($sin) ? abs($width / $sin) : $width;
    my $decal = ($side eq 'outside') ? -90 : 90;

    my @shift_pt = &rad_point($pt, $delta, $bisecangle+$decal);
    push (@pts,  @shift_pt);
    push (@pts,  @{$pt});

    if (!$smoothed and $i) {
      push (@pts, @shift_pt);
      push (@pts,  @{$pt});
    }

    my $faceangle = 360 -(&lineNormal($previous, $next)+90);

    my $light = abs($lightangle - $faceangle);
    $light = 360 - $light if ($light > 180);
    $light = 1 if $light < 1;

    my $lumratio = ($relief eq 'sunken') ? (180-$light)/180 : $light/180;

    if (!$smoothed and $i) {
      push(@colors, ($colors[-2],$colors[-1]));
    }

   if ($basiccolor) {
     # création des couleurs dérivées
     my $shade = &LightingColor($basiccolor, $lumratio);
     my $color0 = $shade.";".$reliefalphas->[0];
     my $color1 = $shade.";".$reliefalphas->[1];
     push(@colors, ($color0, $color1));

   } else {
      my $c = (255*$lumratio);
      my $color0 = &hexaRGBcolor($c, $c, $c, $reliefalphas->[0]);
      my $color1 = &hexaRGBcolor($c, $c, $c, $reliefalphas->[1]);
      push(@colors, ($color0, $color1));
    }

    if ($i == $numfaces - 2) {
      $next = ($closed) ? $coords->[0] :
	[$coords->[$i+1]->[0] + ($coords->[$i+1]->[0] - $pt->[0]), $coords->[$i+1]->[1] + ($coords->[$i+1]->[1] - $pt->[1])];
    } else {
      $next = $coords->[$i+2];
    }

    $previous = $coords->[$i];
  }

  if ($closed) {
    push (@pts, ($pts[0], $pts[1], $pts[2], $pts[3]));
    push (@colors, ($colors[0], $colors[1]));

    if (!$smoothed) {
      push (@pts, ($pts[0], $pts[1], $pts[2], $pts[3]));
      push (@colors, ($colors[0], $colors[1]));
    }

  }


  return (\@pts, \@colors);
}


#-----------------------------------------------------------------------------------
# Graphics::graphicItemShadow
# Création d'une ombre portée à l'item
#-----------------------------------------------------------------------------------
# paramètres :
#  widget : <widget> identifiant widget Zinc
#    item : <tagOrId> identifiant item Zinc
# options : <hash> table d'options
#    -opacity : <percent> opacité de l'ombre (défaut 50)
#     -filled : <boolean> remplissage totale de l'ombre (hors bordure) (defaut 1)
# -lightangle : <angle> angle d'éclairage (défaut valeur générale widget)
#   -distance : <dimension> distance de projection de l'ombre en pixel
#  -enlarging : <dimension> grossi de l'ombre portée en pixels (defaut 0)
#      -width : <dimension> taille de diffusion/diffraction (défaut 4)
#      -color : <color> couleur de l'ombre portée (défaut black)
#-----------------------------------------------------------------------------------
sub graphicItemShadow {
  my ($widget, $item, %options) = @_;
  my @items;

  # relief d'une liste d'items -> appel récursif
  if (ref($item) eq 'ARRAY') {
    foreach my $part (@{$item}) {
      push(@items, &graphicItemShadow($widget, $part, %options));
    }

    return \@items;

  } else {

    my $itemtype = $widget->type($item);

    return unless ($itemtype);

    # création d'un groupe à l'ombre portée
    my $parentgroup = ($options{'-parentgroup'}) ? $options{'-parentgroup'} :
      $widget->group($item);
    my $priority = (defined $options{'-priority'}) ? $options{'-priority'} :
      ($widget->itemcget($item, -priority))-1;
    $priority = 0 if ($priority < 0);

    my $shadow = $widget->add('group', $parentgroup, -priority => $priority);

    if ($itemtype eq 'text') {
      my $opacity = (defined $options{'-opacity'}) ? $options{'-opacity'} : 50;
      my $color = ($options{'-color'}) ? $options{'-color'} : '#000000';

      my $clone = $widget->clone($item, -color => $color.";".$opacity);
      $widget->chggroup($clone, $shadow);

    } else {

      # création des items (de dessin) de l'ombre
      my $filled = (defined $options{'-filled'}) ? $options{'-filled'} : 1;

      # coords transformés (polyline) de l'item
      foreach my $coords (&ZincItem2CurveCoords($widget, $item, -linear => 1, -realcoords => 1)) {
	my ($t_pts, $i_pts, $colors) = &polylineShadowParams($widget, $item, $coords, %options);

	# option filled : remplissage hors bordure de l'ombre portée (item curve)
	if ($filled) {
	  if (@items) {
	    $widget->contour($items[0], 'add', 0, $i_pts);
	
	  } else {
	    push(@items, $widget->add('curve', $shadow, $i_pts,
				      -linewidth => 0,
				      -filled => 1,
				      -fillcolor => $colors->[0],
				     ));
	  }
	}
	
	# bordure de diffusion de l'ombre (item triangles)
	push(@items, $widget->add('triangles', $shadow, $t_pts,
			      -colors => $colors));
      }
    }

    # positionnement de l'ombre portée
    my $distance = (defined $options{'-distance'}) ? $options{'-distance'} : 10;
    my $lightangle = (defined $options{'-lightangle'}) ? $options{'-lightangle'}
      : $widget->cget('-lightangle');

    my ($dx, $dy) = &rad_point([0, 0], $distance, $lightangle+180);
    $widget->translate($shadow, $dx, -$dy);

    return $shadow;

  }

}


#-----------------------------------------------------------------------------------
# Graphics::polylineShadowParams
# retourne les listes des points et de couleurs nécessaires à la construction des
# items triangles (bordure externe) et curve (remplissage interne) de l'ombre portée
#-----------------------------------------------------------------------------------
# paramètres :
#  widget : <widget> identifiant widget Zinc
#    item : <tagOrId> identifiant item Zinc
# options : <hash> table d'options
#    -opacity : <percent> opacité de l'ombre (défaut 50)
# -lightangle : <angle> angle d'éclairage (défaut valeur générale widget)
#   -distance : <dimension> distance de projection de l'ombre en pixel (défaut 10)
#  -enlarging : <dimension> grossi de l'ombre portée en pixels (defaut 2)
#      -width : <dimension> taille de diffusion/diffraction (défaut distance -2)
#      -color : <color> couleur de l'ombre portée (défaut black)
#-----------------------------------------------------------------------------------
sub polylineShadowParams {
  my ($widget, $item, $coords, %options) = @_;

  my $distance = (defined $options{'-distance'}) ? $options{'-distance'} : 10;
  my $width = (defined $options{'-width'}) ? $options{'-width'} : $distance-2;
  my $opacity = (defined $options{'-opacity'}) ? $options{'-opacity'} : 50;
  my $color = ($options{'-color'}) ? $options{'-color'} : '#000000';
  my $enlarging = (defined $options{'-enlarging'}) ? $options{'-enlarging'} : 2;

  if ($enlarging) {
    $coords = &shiftPathCoords($coords, -width => $enlarging, -closed => 1, -shifting => 'out');
  }

  my $numfaces = scalar(@{$coords});
  my $previous = $coords->[$numfaces - 1];
  my $next = $coords->[1];

  my @t_pts;
  my @i_pts;
  my @colors;
  my ($color0, $color1) = ($color.";$opacity", $color.";0");

  for (my $i = 0; $i < $numfaces; $i++) {
    my $pt = $coords->[$i];

    if (!$previous) {
      # extrémité de curve sans raccord -> angle plat
      $previous = [$pt->[0] + ($pt->[0] - $next->[0]), $pt->[1] + ($pt->[1] - $next->[1])];
    }

    my ($angle, $bisecangle) = &vertexAngle($previous, $pt, $next);

    # distance au centre du cercle inscrit : rayon/sinus demi-angle
    my $sin = sin(deg2rad($angle/2));
    my $delta = ($sin) ? abs($width / $sin) : $width;
    my $decal = 90;

    my @shift_pt = &rad_point($pt, $delta, $bisecangle+$decal);
    push (@i_pts,  @shift_pt);
    push (@t_pts,  @shift_pt);
    push (@t_pts,  @{$pt});

    push(@colors, ($color0, $color1));

    if ($i == $numfaces - 2) {
      $next = $coords->[0];
    } else {
      $next = $coords->[$i+2];
    }

    $previous = $coords->[$i];
  }

  # fermeture
  push(@t_pts, ($t_pts[0], $t_pts[1],$t_pts[2],$t_pts[3]));
  push(@i_pts, ($t_pts[0], $t_pts[1]));
  push(@colors, ($color0, $color1,$color0,$color1));

  return (\@t_pts, \@i_pts, \@colors);
}


#-----------------------------------------------------------------------------------
# Graphics::bezierSegment
# Calcul d'une approximation de segment (Quadratique ou Cubique) de bezier
#-----------------------------------------------------------------------------------
# paramètres :
#    points : <[P1, C1, <C1>, P2]> liste des points définissant le segment de bezier
#
# options :
#  -tunits : <integer> nombre pas de division des segments bezier (par défaut 20)
# -skipend : <boolean> : ne pas retourner le dernier point du segment (chainage)
#-----------------------------------------------------------------------------------
sub bezierSegment {
  my ($coords, %options) = @_;
  my $tunits = ($options{'-tunits'}) ? $options{'-tunits'} : 20;
  my $skipendpt = $options{'-skipend'};

  my @pts;

  my $lastpt = ($skipendpt) ? $tunits-1 : $tunits;
  foreach (my $i = 0; $i <= $lastpt; $i++) {
    my $t = ($i) ? ($i/$tunits) : $i;
    push(@pts, &bezierPoint($t, $coords));
  }

  return wantarray ? @pts : \@pts;

}


#-----------------------------------------------------------------------------------
# Graphics::bezierPoint
# calcul d'un point du segment (Quadratique ou Cubique) de bezier
# params :
# t = <n> (représentation du temps : de 0 à 1)
# coords = (P1, C1, <C1>, P2) liste des points définissant le segment de bezier
# P1 et P2 : extémités du segment et pts situés sur la courbe
# C1 <C2> : point(s) de contrôle du segment
#-----------------------------------------------------------------------------------
# courbe bezier niveau 2 sur (P1, P2, P3)
# P(t) = (1-t)²P1 + 2t(1-t)P2 + t²P3
#
# courbe bezier niveau 3 sur (P1, P2, P3, P4)
# P(t) = (1-t)³P1 + 3t(1-t)²P2 + 3t²(1-t)P3 + t³P4
#-----------------------------------------------------------------------------------
sub bezierPoint {
  my ($t, $coords) = @_;
  my ($p1, $c1, $c2, $p2) = @{$coords};

  # quadratique
  if (!defined $p2) {
    $p2 = $c2;
    $c2 = undef;
  }

  # extrémités : points sur la courbe
  return wantarray ? @{$p1} : $p1 if (!$t);
  return wantarray ? @{$p2} : $p2 if ($t >= 1.0);


  my $t2 = $t * $t;
  my $t3 = $t2 * $t;
  my @pt;

  # calcul pour x et y
  foreach my $i (0, 1) {

    if (defined $c2) {
      my $r1 = (1 - (3*$t) + (3*$t2) -    $t3)  * $p1->[$i];
      my $r2 = (    (3*$t) - (6*$t2) + (3*$t3)) * $c1->[$i];
      my $r3 = (             (3*$t2) - (3*$t3)) * $c2->[$i];
      my $r4 = (                          $t3)  * $p2->[$i];

      $pt[$i] = ($r1 + $r2 + $r3 + $r4);

    } else {
      my $r1 = (1 - (2*$t) +    $t2)  * $p1->[$i];
      my $r2 = (    (2*$t) - (2*$t2)) * $c1->[$i];
      my $r3 = (                $t2)  * $p2->[$i];

      $pt[$i] = ($r1 + $r2 + $r3);
    }
  }

  #return wantarray ? @pt : \@pt;
  return \@pt;

}


#-----------------------------------------------------------------------------------
# Graphics::bezierCompute
# Retourne une liste de coordonnées décrivant un segment de bezier
#-----------------------------------------------------------------------------------
# paramètres :
#     coords : <coordsList> liste des points définissant le segment de bezier
#
# options :
# -precision : <dimension> seuil limite du calcul d'approche de la courbe
#   -skipend : <boolean> : ne pas retourner le dernier point du segment (chaînage bezier)
#-----------------------------------------------------------------------------------
sub bezierCompute {
  my ($coords, %options) = @_;
  my $precision = ($options{'-precision'}) ? $options{'-precision'} : $bezierClosenessThreshold;
  my $lastit = [];

  &subdivideBezier($coords, $lastit, $precision);

  push(@{$lastit}, $coords->[3]) if (!$options{'-skipend'});

  return wantarray ? @{$lastit} : $lastit;
}

#------------------------------------------------------------------------------------
# Graphics::smallEnought
# intégration code Stéphane Conversy : calcul points bezier (précision auto ajustée)
#------------------------------------------------------------------------------------
# distance is something like num/den with den=sqrt(something)
# what we want is to test that distance is smaller than precision,
# so we have distance < precision ?  eq. to distance^2 < precision^2 ?
# eq. to (num^2/something) < precision^2 ?
# eq. to num^2 < precision^2*something
# be careful with huge values though (hence 'long long')
# with common values: 9add 9mul
#------------------------------------------------------------------------------------
sub smallEnoughBezier {
  my ($bezier, $precision) = @_;
  my ($x, $y) = (0, 1);
  my ($A, $B) = ($bezier->[0], $bezier->[3]);

  my $den = (($A->[$y]-$B->[$y])*($A->[$y]-$B->[$y])) + (($B->[$x]-$A->[$x])*($B->[$x]-$A->[$x]));
  my $p = $precision*$precision;

  # compute distance between P1|P2 and P0|P3
  my $M = $bezier->[1];
  my $num1 = (($M->[$x]-$A->[$x])*($A->[$y]-$B->[$y])) + (($M->[$y]-$A->[$y])*($B->[$x]-$A->[$x]));

  $M = $bezier->[2];
  my $num2 = (($M->[$x]-$A->[$x])*($A->[$y]-$B->[$y])) + (($M->[$y]-$A->[$y])*($B->[$x]-$A->[$x]));

  # take the max
  $num1 = $num2 if ($num2 > $num1);

  return ($p*$den > ($num1*$num1)) ? 1 : 0;

}

#-----------------------------------------------------------------------------------
# Graphics::subdivideBezier
# subdivision d'une courbe de bezier
#-----------------------------------------------------------------------------------
sub subdivideBezier {
  my ($bezier, $it, $precision, $integeropt) = @_;
  my ($b0, $b1, $b2, $b3) = @{$bezier};

  if (&smallEnoughBezier($bezier, $precision)) {
    push(@{$it}, ([$b0->[0],$b0->[1]]));

  } else {
    my ($left, $right);

    foreach my $i (0, 1) {

      if ($integeropt) {
	# int optimized (6+3=9)add + (5+3=8)shift

	$left->[0][$i] = $b0->[$i];
	$left->[1][$i] = ($b0->[$i] + $b1->[$i]) >> 1;
	$left->[2][$i] = ($b0->[$i] + $b2->[$i] + ($b1->[$i] << 1)) >> 2; # keep precision
	my $tmp = ($b1->[$i] + $b2->[$i]);
	$left->[3][$i] = ($b0->[$i] + $b3->[$i] + ($tmp << 1) + $tmp) >> 3;

	$right->[3][$i] = $b3->[$i];
	$right->[2][$i] = ($b3->[$i] + $b2->[$i]) >> 1;
	$right->[1][$i] = ($b3->[$i] + $b1->[$i] + ($b2->[$i] << 1) ) >> 2; # keep precision
	$right->[0][$i] = $left->[3]->[$i];

      } else {
	# float

	$left->[0][$i] = $b0->[$i];
	$left->[1][$i] = ($b0->[$i] + $b1->[$i]) / 2;
	$left->[2][$i] = ($b0->[$i] + (2*$b1->[$i]) + $b2->[$i]) / 4;
	$left->[3][$i] = ($b0->[$i] + (3*$b1->[$i]) + (3*$b2->[$i]) + $b3->[$i]) / 8;

	$right->[3][$i] = $b3->[$i];
	$right->[2][$i] = ($b3->[$i] + $b2->[$i]) / 2;
	$right->[1][$i] = ($b3->[$i] + (2*$b2->[$i]) + $b1->[$i]) / 4;
	$right->[0][$i] = ($b3->[$i] + (3*$b2->[$i]) + (3*$b1->[$i]) + $b0->[$i]) / 8;

      }
    }

    &subdivideBezier($left, $it, $precision, $integeropt);
    &subdivideBezier($right, $it, $precision, $integeropt);

  }
}



#-----------------------------------------------------------------------------------
# RESOURCES GRAPHIQUES PATTERNS, TEXTURES, IMAGES, GRADIENTS, COULEURS...
#-----------------------------------------------------------------------------------
#-----------------------------------------------------------------------------------
# Graphics::getPattern
# retourne la ressource bitmap en l'initialisant si première utilisation
#-----------------------------------------------------------------------------------
# paramètres :
# filename : nom du fichier bitmap pattern
# options
# -storage : <hastable> référence de la table de stockage de patterns
#-----------------------------------------------------------------------------------
sub getPattern {
  my ($filename, %options) = @_;
  my $table = (defined $options{'-storage'} and ref($options{'-storage'}) eq 'HASH') ? 
    $options{'-storage'} : \%bitmaps;

  if (!exists($table->{$filename})) {
    my $bitmap = '@'.Tk::findINC($filename);
    $table->{$filename} = $bitmap if $bitmap;

  }

  return $table->{$filename};
}

#-----------------------------------------------------------------------------------
# Graphics::getTexture
# retourne l'image de texture en l'initialisant si première utilisation
#-----------------------------------------------------------------------------------
# paramètres :
#   widget : <widget> identifiant du widget zinc
# filename : nom du fichier texture
# options
# -storage : <hastable> référence de la table de stockage de textures
#-----------------------------------------------------------------------------------
sub getTexture {
  my ($widget, $filename, %options) = @_;
  my $table = (defined $options{'-storage'} and ref($options{'-storage'}) eq 'HASH') ? 
    $options{'-storage'} : \%textures;

  return &getImage($widget, $filename, -storage => $table);

}

#-----------------------------------------------------------------------------------
# Graphics::getImage
# retourne la ressource image en l'initialisant si première utilisation
#-----------------------------------------------------------------------------------
# paramètres :
#   widget : <widget> identifiant du widget zinc
# filename : nom du fichier image
# options
# -storage : <hastable> référence de la table de stockage d'images
#-----------------------------------------------------------------------------------
sub getImage {
  my ($widget, $filename, %options) = @_;
  my $table = (defined $options{'-storage'} and ref($options{'-storage'}) eq 'HASH') ? 
    $options{'-storage'} : \%images;

  if (!exists($table->{$filename})) {
    my $image;
    if ($filename =~ /.png|.PNG/) {
      $image = $widget->Photo(-format => 'png', -file => Tk::findINC($filename));

    } elsif ($filename =~ /.jpg|.JPG|.jpeg|.JPEG/) {
      $image = $widget->Photo(-format => 'jpeg', -file => Tk::findINC($filename));

    } else {
      $image = $widget->Photo(-file => Tk::findINC($filename));
    }

    $table->{$filename} = $image if $image;

  }

  return $table->{$filename};

}


#-----------------------------------------------------------------------------------
# Graphics::init_pixmaps
# initialise une liste de fichier image
#-----------------------------------------------------------------------------------
# paramètres :
#    widget : <widget> identifiant du widget zinc
# filenames : <filenameList> list des noms des fichier image
# options
#  -storage : <hastable> référence de la table de stockage d'images
#-----------------------------------------------------------------------------------
sub init_pixmaps {
  my ($widget, $filenames, %options) = @_;
  my @imgs = ();

  my @files = (ref($filenames) eq 'ARRAY') ? @{$filenames} : ($filenames);

  foreach (@files) {
    push(@imgs, &getImage($widget, $_, %options));
  }

  return @imgs;
}


#-----------------------------------------------------------------------------------
# Graphics::_min
# retourne la plus petite valeur entre 2 valeurs
#-----------------------------------------------------------------------------------
sub _min {
  my ($n1, $n2) = @_;
  my $mini = ($n1 > $n2) ? $n2 : $n1;
  return $mini;

}

#-----------------------------------------------------------------------------------
# Graphics::_max
# retourne la plus grande valeur entre 2 valeurs
#-----------------------------------------------------------------------------------
sub _max {
  my ($n1, $n2) = @_;
  my $maxi = ($n1 > $n2) ? $n1 : $n2;
  return $maxi;

}

#-----------------------------------------------------------------------------------
# Graphics::_trunc
# fonction interne de troncature des nombres: n = position décimale 
#-----------------------------------------------------------------------------------
sub _trunc {
  my ($val, $n) = @_;
  my $str;
  my $dec;

  ($val) =~ /([0-9]+)\.?([0-9]*)/;
  $str = ($val < 0) ? "-$1" : $1;

  if (($2 ne "") && ($n != 0)) {
    $dec = substr($2, 0, $n);
    if ($dec != 0) {
      $str = $str . "." . $dec;
    }
  }
  return $str;
}

#-----------------------------------------------------------------------------------
# Graphics::setGradients
# création de gradient nommés Zinc
#-----------------------------------------------------------------------------------
# paramètres :
#   widget : <widget> identifiant du widget zinc
#    grads : <hastable> table de hash de définition de couleurs zinc
#-----------------------------------------------------------------------------------
sub setGradients {
  my ($widget, $grads) = @_;

  # initialise les gradients de taches
  unless (@Gradients) {
    while (my ($name, $gradient) = each( %{$grads})) {
      # création des gradients nommés
      $widget->gname($gradient, $name);
      push(@Gradients, $name);
    }
  }
}


#-----------------------------------------------------------------------------------
# Graphics::RGB_dec2hex
# conversion d'une couleur RGB (255,255,255) au format Zinc '#ffffff'
#-----------------------------------------------------------------------------------
# paramètres :
#  rgb : <rgbColorList> liste de couleurs au format RGB
#-----------------------------------------------------------------------------------
sub RGB_dec2hex {
   my (@rgb) = @_;
   return (sprintf("#%04x%04x%04x", @rgb));
}

#-----------------------------------------------------------------------------------
# Graphics::pathGraduate
# création d'un jeu de couleurs dégradées pour item pathLine
#-----------------------------------------------------------------------------------
sub pathGraduate {
  my ($widget, $numcolors, $style) = @_;

  my $type = $style->{'-type'};
  my $triangles_colors;

  if ($type eq 'linear') {
    return &createGraduate($widget, $numcolors, $style->{'-colors'}, 2);

  } elsif ($type eq 'double') {
    my $colors1 = &createGraduate($widget, $numcolors/2+1, $style->{'-colors'}->[0]);
    my $colors2 = &createGraduate($widget, $numcolors/2+1, $style->{'-colors'}->[1]);
    my @colors;
    for (my $i = 0; $i <= $numcolors; $i++) {
      push(@colors, ($colors1->[$i], $colors2->[$i]));
    }

    return \@colors;

  } elsif ($type eq 'transversal') {
    my ($c1, $c2) = @{$style->{'-colors'}};
    my @colors = ($c1, $c2);
    for (my $i = 0; $i < $numcolors; $i++) {
      push(@colors, ($c1, $c2));
    }

    return \@colors;
  }
}

#-----------------------------------------------------------------------------------
# Graphics::createGraduate
# création d'un jeu de couleurs intermédiaires (dégradé) entre n couleurs
#-----------------------------------------------------------------------------------
sub createGraduate {
  my ($widget, $totalsteps, $refcolors, $repeat) = @_;
  my @colors;

  $repeat = 1 if (!$repeat);
  my $numgraduates = scalar @{$refcolors} - 1;

  if ($numgraduates < 1) {
    print "Le dégradé necessite au minimum 2 couleurs de référence...\n";
    return undef;
  }

  my $steps = ($numgraduates > 1) ? $totalsteps/($numgraduates -1) : $totalsteps;

  for (my $c = 0; $c < $numgraduates; $c++) {
    my ($c1, $c2) = ($refcolors->[$c], $refcolors->[$c+1]);

    for (my $i = 0 ; $i < $steps ; $i++) {
      my $color = MedianColor($c1, $c2, $i/($steps-1));
      for (my $k = 0; $k < $repeat; $k++) {
	push (@colors, $color);
      }
    }

    if ($c < $numgraduates - 1) {
      for (my $k = 0; $k < $repeat; $k++) {
	pop @colors;
      }
    }
  }

  return \@colors;
}

#-----------------------------------------------------------------------------------
# Graphics::LightingColor
# modification d'une couleur par sa composante luminosité
#-----------------------------------------------------------------------------------
# paramètres :
#  color : <color> couleur au format zinc
#   newL : <pourcent> (de 0 à 1) nouvelle valeur de luminosité
#-----------------------------------------------------------------------------------
sub LightingColor {
    my ($color, $newL) = @_;
    my ($H, $L, $S);

    if ($color and $newL) {
      my ($RGB) = &hexa2RGB($color);
      ($H, $L, $S) = @{&RGBtoHLS(@{$RGB})};


      $newL = 1 if $newL > 1;		
      my ($nR, $nG, $nB) = @{&HLStoRGB($H, $newL, $S)};
      return &hexaRGBcolor($nR*255, $nG*255, $nB*255);
	
    }

    return undef;
}


#-----------------------------------------------------------------------------------
# Graphics::zincItemPredominantColor
# retourne la couleur dominante d'un item ('barycentre' gradiant fillcolor)
#-----------------------------------------------------------------------------------
# paramètres :
#  widget : <widget> identifiant du widget zinc
#    item : <tagOrId> identifiant de l'item zinc
#-----------------------------------------------------------------------------------
sub zincItemPredominantColor {
  my ($widget, $item) = @_;
  my $type = $widget->type($item);

  if ($type eq 'text' or '$type' eq 'icon') {
    return $widget->itemcget($item, -color);

  } elsif ($type eq 'triangles' or
	   $type eq 'rectangle' or
	   $type eq 'arc' or
	   $type eq 'curve') {

    my @colors;

    if ($type eq 'triangles') {
      @colors =  $widget->itemcget($item, -colors);

    } else {
      my $grad =  $widget->itemcget($item, -fillcolor);
      
      return $grad if (scalar (my @unused = (split / /, $grad)) < 2);
	
      my @colorparts = split /\|/, $grad;
      foreach my $section (@colorparts) {
	if ($section !~ /=/) {
	  my ($color, $director, $position) = split / /, $section;
	  push (@colors, $color);
	}
      }
    }
	

    my ($Rs, $Gs, $Bs, $As, $numcolors) = (0, 0, 0, 0, 0);
    foreach my $color (@colors) {
      my ($r, $g, $b, $a) = ZnColorToRGB($color);
      $Rs += $r;
      $Gs += $g;
      $Bs += $b;
      $As += $a;
      $numcolors++;
    }

    my $newR = int($Rs/$numcolors);
    my $newG = int($Gs/$numcolors);
    my $newB = int($Bs/$numcolors);
    my $newA = int($As/$numcolors);

    my $newcolor = &hexaRGBcolor($newR, $newG, $newB, $newA);

    return $newcolor

  } else {
    return '#777777';
  }
}

#-----------------------------------------------------------------------------------
# Graphics::MedianColor
# calcul d'une couleur intermédiaire défini par un ratio ($rate) entre 2 couleurs
#-----------------------------------------------------------------------------------
# paramètres :
#  color1 : <color> première couleur zinc
#  color2 : <color> seconde couleur zinc
#    rate : <pourcent> (de 0  à 1) position de la couleur intermédiaire
#-----------------------------------------------------------------------------------
sub MedianColor {
  my ($color1, $color2, $rate) = @_;
  $rate = 1 if ($rate > 1);
  $rate = 0 if ($rate < 0);

  my ($r0, $g0, $b0, $a0) = &ZnColorToRGB($color1);
  my ($r1, $g1, $b1, $a1) = &ZnColorToRGB($color2);

  my $r = $r0 + int(($r1 - $r0) * $rate);
  my $g = $g0 + int(($g1 - $g0) * $rate);
  my $b = $b0 + int(($b1 - $b0) * $rate);
  my $a = $a0 + int(($a1 - $a0) * $rate);

  return &hexaRGBcolor($r, $g, $b, $a);
}


#-----------------------------------------------------------------------------------
# Graphics::ZnColorToRGB
# conversion d'une couleur Zinc au format RGBA (255,255,255,100)
#-----------------------------------------------------------------------------------
# paramètres :
#  zncolor : <color> couleur au format hexa zinc (#ffffff ou #ffffffffffff)
#-----------------------------------------------------------------------------------
sub ZnColorToRGB {
  my ($zncolor) = @_;

  my ($color, $alpha) = split /;/, $zncolor;
  my $ndigits = (length($color) > 8) ? 4 : 2;
  my $R = hex(substr($color, 1, $ndigits));
  my $G = hex(substr($color, 1+$ndigits, $ndigits));
  my $B = hex(substr($color, 1+($ndigits*2), $ndigits));

  $alpha = 100 if (!defined $alpha or $alpha eq "");

  return ($R, $G, $B, $alpha);

}

#-----------------------------------------------------------------------------------
# ALGORYTHMES DE CONVERSION ENTRE ESPACES DE COULEURS
#-----------------------------------------------------------------------------------
#-----------------------------------------------------------------------------------
# Graphics::RGBtoLCH
# Algorythme de conversion RGB -> CIE LCH°
#-----------------------------------------------------------------------------------
# paramètres :
#  r : <pourcent> (de 0 à 1) valeur de la composante rouge de la couleur RGB
#  g : <pourcent> (de 0 à 1) valeur de la composante verte de la couleur RGB
#  b : <pourcent> (de 0 à 1) valeur de la composante bleue de la couleur RGB
#-----------------------------------------------------------------------------------
sub  RGBtoLCH {
  my ($r, $g, $b) = @_;

  # Conversion RGBtoXYZ
  my $gamma = 2.4;
  my $rgblimit = 0.03928;


  $r = ($r > $rgblimit) ? (($r + 0.055)/1.055)**$gamma : $r / 12.92;
  $g = ($g > $rgblimit) ? (($g + 0.055)/1.055)**$gamma : $g / 12.92;
  $b = ($b > $rgblimit) ? (($b + 0.055)/1.055)**$gamma : $b / 12.92;

  $r *= 100;
  $g *= 100;
  $b *= 100;

  my $X = (0.4124 * $r) + (0.3576 * $g) + (0.1805 * $b);
  my $Y = (0.2126 * $r) + (0.7152 * $g) + (0.0722 * $b);
  my $Z = (0.0193 * $r) + (0.1192 * $g) + (0.9505 * $b);


  # Conversion XYZtoLab
  $gamma = 1/3;
  my ($L, $A, $B);

  if ($Y == 0) {
    ($L, $A, $B) = (0, 0, 0);

  } else {

    my ($Xs, $Ys, $Zs) = ($X/$Xw, $Y/$Yw, $Z/$Zw);
	
    $Xs = ($Xs > 0.008856) ? $Xs**$gamma : (7.787 * $Xs) + (16/116);
    $Ys = ($Ys > 0.008856) ? $Ys**$gamma : (7.787 * $Ys) + (16/116);
    $Zs = ($Zs > 0.008856) ? $Zs**$gamma : (7.787 * $Zs) + (16/116);

    $L = (116.0 * $Ys) - 16.0;

    $A = 500 * ($Xs - $Ys);
    $B = 200 * ($Ys - $Zs);

  }

  # conversion LabtoLCH 
  my ($C, $H);


  if ($A == 0) {
    $H = 0;

  } else {

    $H = atan2($B, $A);
	
    if ($H > 0) {
      $H = ($H / pi) * 180;

    } else {
      $H = 360 - ( abs($H) / pi) * 180
    }
  }


  $C = sqrt($A**2 + $B**2);

  return [$L, $C, $H];

}


#-----------------------------------------------------------------------------------
# Graphics::LCHtoRGB
# Algorythme de conversion CIE L*CH -> RGB
#-----------------------------------------------------------------------------------
# paramètres :
#  L : <pourcent> (de 0 à 1) valeur de la composante luminosité de la couleur CIE LCH
#  C : <pourcent> (de 0 à 1) valeur de la composante saturation de la couleur CIE LCH
#  H : <pourcent> (de 0 à 1) valeur de la composante teinte de la couleur CIE LCH
#-----------------------------------------------------------------------------------
sub LCHtoRGB {
  my ($L, $C, $H) = @_;
  my ($a, $b);

  # Conversion LCHtoLab
  $a = cos( deg2rad($H)) * $C;
  $b = sin( deg2rad($H)) * $C;

  # Conversion LabtoXYZ
  my $gamma = 3;
  my ($X, $Y, $Z);

  my $Ys = ($L + 16.0) / 116.0;
  my $Xs = ($a / 500) + $Ys;
  my $Zs = $Ys - ($b / 200);


  $Ys = (($Ys**$gamma) > 0.008856) ? $Ys**$gamma : ($Ys - 16 / 116) / 7.787;
  $Xs = (($Xs**$gamma) > 0.008856) ? $Xs**$gamma : ($Xs - 16 / 116) / 7.787;
  $Zs = (($Zs**$gamma) > 0.008856) ? $Zs**$gamma : ($Zs - 16 / 116) / 7.787;


  $X = $Xw * $Xs;
  $Y = $Yw * $Ys;
  $Z = $Zw * $Zs;

  # Conversion XYZtoRGB
  $gamma = 1/2.4;
  my $rgblimit = 0.00304;
  my ($R, $G, $B);


  $X /= 100;
  $Y /= 100;
  $Z /= 100;

  $R = (3.2410 * $X) + (-1.5374 * $Y) + (-0.4986 * $Z);
  $G = (-0.9692 * $X) + (1.8760 * $Y) + (0.0416 * $Z);
  $B = (0.0556 * $X) + (-0.2040 * $Y) + (1.0570 * $Z);

  $R = ($R > $rgblimit) ? (1.055 * ($R**$gamma)) - 0.055 : (12.92 * $R);
  $G = ($G > $rgblimit) ? (1.055 * ($G**$gamma)) - 0.055 : (12.92 * $G);
  $B = ($B > $rgblimit) ? (1.055 * ($B**$gamma)) - 0.055 : (12.92 * $B);

  $R = ($R < 0) ? 0 : ($R > 1.0) ? 1.0 : &_trunc($R, 5);
  $G = ($G < 0) ? 0 : ($G > 1.0) ? 1.0 : &_trunc($G, 5);
  $B = ($B < 0) ? 0 : ($B > 1.0) ? 1.0 : &_trunc($B, 5);

  return [$R, $G, $B];

}

#-----------------------------------------------------------------------------------
# Graphics::RGBtoHLS
# Algorythme de conversion RGB -> HLS
#-----------------------------------------------------------------------------------
#  r : <pourcent> (de 0 à 1) valeur de la composante rouge de la couleur RGB
#  g : <pourcent> (de 0 à 1) valeur de la composante verte de la couleur RGB
#  b : <pourcent> (de 0 à 1) valeur de la composante bleue de la couleur RGB
#-----------------------------------------------------------------------------------
sub RGBtoHLS {
  my ($r, $g, $b) = @_;
  my ($H, $L, $S);
  my ($min, $max, $diff);


  $max = &max($r,$g,$b);
  $min = &min($r,$g,$b);

  # calcul de la luminosité
  $L = ($max + $min) / 2;

  # calcul de la saturation
  if ($max == $min) {
    # couleur a-chromatique (gris) $r = $g = $b
    $S = 0;
    $H = undef;

    return [$H, $L, $S];
  }

  # couleurs "Chromatiques" --------------------

  # calcul de la saturation
  if ($L <= 0.5) {
    $S = ($max - $min) / ($max + $min);

  } else {
    $S = ($max - $min) / (2 - $max - $min);

  }

  # calcul de la teinte
  $diff = $max - $min;

  if ($r == $max) {
    # couleur entre jaune et magenta
    $H = ($g - $b) / $diff;

  } elsif ($g == $max) {
    # couleur entre cyan et jaune
    $H = 2 + ($b - $r) / $diff;

  } elsif ($b == $max) {
    # couleur entre magenta et cyan
    $H = 4 + ($r - $g) / $diff;
  }

  # Conversion en degrés
  $H *= 60;

  # pour éviter une valeur négative
  if ($H < 0.0) {
    $H += 360;
  }

  return [$H, $L, $S];

}


#-----------------------------------------------------------------------------------
# Graphics::HLStoRGB
# Algorythme de conversion HLS -> RGB
#-----------------------------------------------------------------------------------
# paramètres :
#  H : <pourcent> (de 0 à 1) valeur de la composante teinte de la couleur HLS
#  L : <pourcent> (de 0 à 1) valeur de la composante luminosité de la couleur HLS
#  S : <pourcent> (de 0 à 1) valeur de la composante saturation de la couleur HLS
#-----------------------------------------------------------------------------------
sub HLStoRGB {
  my ($H, $L, $S) = @_;
  my ($R, $G, $B);
  my ($p1, $p2);


  if ($L <= 0.5) { 
    $p2 = $L + ($L * $S);
	
  } else {
    $p2 = $L + $S - ($L * $S);

  }

  $p1 = 2.0 * $L - $p2;

  if ($S == 0) {
    # couleur a-chromatique (gris)
    # $R = $G = $B = $L
    $R = $L;
    $G = $L;
    $B = $L;

  } else {
    # couleurs "Chromatiques"
    $R = &hlsValue($p1, $p2, $H + 120);
    $G = &hlsValue($p1, $p2, $H);
    $B = &hlsValue($p1, $p2, $H - 120);
	
  }

  return [$R, $G, $B];

}

#-----------------------------------------------------------------------------------
# Graphics::hlsValue (sous fonction interne HLStoRGB)
#-----------------------------------------------------------------------------------
sub hlsValue {
  my ($q1, $q2, $hue) = @_;
  my $value;

  $hue = &r_modp($hue, 360);

  if ($hue < 60) { 
    $value = $q1 + ($q2 - $q1) * $hue / 60;

  } elsif ($hue < 180) { 
    $value = $q2;

  } elsif ($hue < 240) { 
    $value = $q1 + ($q2 - $q1) * (240 - $hue) / 60;

  } else {
    $value = $q1;

  }

  return $value;

}


#-----------------------------------------------------------------------------------
# Graphics::hexaRGBcolor
# conversion d'une couleur RGB (255,255,255) au format Zinc '#ffffff'
#-----------------------------------------------------------------------------------
sub hexaRGBcolor {
   my ($r, $g, $b, $a) = @_;

   if (defined $a) {
     my $hexacolor = sprintf("#%02x%02x%02x", ($r, $g, $b));
     return ($hexacolor.";".$a);
   }

   return (sprintf("#%02x%02x%02x", ($r, $g, $b)));
}



sub hexa2RGB {
  my ($hexastr) = @_;
  my ($r, $g, $b);

  if ($hexastr =~ /(\w\w)(\w\w)(\w\w)/) {
    $r = hex($1);
    $g = hex($2);
    $b = hex($3);

    return [$r/255, $g/255, $b/255] if (defined $r and defined $g and defined $b);

  }

  return undef;
}

#-----------------------------------------------------------------------------------
# Graphics::max
# renvoie la valeur maximum d'une liste de valeurs
#-----------------------------------------------------------------------------------
sub max {
  my (@values) = @_;
  return undef if !scalar(@values);

  my $max = undef;

  foreach my $val (@values) {
    if (!defined $max or $val > $max) {
      $max = $val;
    }
  }

  return $max;
}


#-----------------------------------------------------------------------------------
# Graphics::min
# renvoie la valeur minimum d'une liste de valeurs
#-----------------------------------------------------------------------------------
sub min {
  my (@values) = @_;
  return undef if !scalar(@values);

  my $min = undef;

  foreach my $val (@values) {
    if (!defined $min or $val < $min) {
      $min = $val;
    }
  }

  return $min;
}


#-----------------------------------------------------------------------------------
# Graphics::r_modp
# fonction interne : renvoie le résultat POSITIF du modulo m d'un nombre x
#-----------------------------------------------------------------------------------
sub r_modp {
  my ($x, $m) = @_;

  return undef if $m == 0;

  my $value = $x%$m;

  if ($value < 0.0) {
    $value = $value + abs($m);
  }

  return $value;

}


1;


__END__

=head1 NAME

Graphics : module Perl facilitant la creation d'objets graphiques complexes 
par une description simplifiee.


=head1 SYNOPSIS

use Graphics;

&GraphicsFunction(@params, ?option => value?, ...);

=head1 DESCRIPTION

Z<>

=head2 Fonctions exportées

=head3 1. Création de composants graphiques

=over

=item B<o> buildZincItem(Z<>)

=item B<o> repeatZincItem(Z<>)

=item B<o> buildTabBoxItem(Z<>)

=back

=head3 2. Calculs de formes géométriques complexes

=over

=item B<o> roundedRectangleCoords(Z<>)

=item B<o> hippodromeCoords(Z<>)

=item B<o> ellipseCoords(Z<>)

=item B<o> roundedCurveCoords(Z<>)

=item B<o> polygonCoords(Z<>)

=item B<o> polylineCoords(Z<>)

=item B<o> curveLineCoords>(Z<>)

=item B<o> pathLineCoords(Z<>)

=item B<o> shiftPathCoords(Z<>)

=item B<o> tabBoxCoords(Z<>)

=back

=head3 3. Création de relief et ombre portée

=over

=item B<o> graphicItemRelief(Z<>)

=item B<o> graphicItemShadow(Z<>)

=back

=head3 4. Fonctions géométriques de base

=over

=item B<o> perpendicularPoint(Z<>)

=item B<o> lineAngle(Z<>)

=item B<o> vertexAngle(Z<>)

=item B<o> arc_pts(Z<>)

=item B<o> rad_point(Z<>)

=item B<o> bezierCompute(Z<>)

=item B<o> bezierSegment(Z<>)

=item B<o> bezierPoint(Z<>)

=back

=head3 5. Gestion des ressources images

=over

=item B<o> getPattern(Z<>)

=item B<o> getTexture(Z<>)

=item B<o> getImage(Z<>)

=item B<o> init_pixmaps(Z<>)

=back

=head3 6. Gestion des couleurs

=over

=item B<o> setGradiants(Z<>)

=item B<o> zincItemPredominantColor(Z<>)

=item B<o> ZnColorToRGB(Z<>)

=item B<o> hexaRGBcolor(Z<>)

=item B<o> createGraduate(Z<>)

=item B<o> MedianColor(Z<>)

=item B<o> LightingColor(Z<>)

=item B<o> RGBtoLCH(Z<>)

=item B<o> LCHtoRGB(Z<>)

=item B<o> RGBtoHLS(Z<>)

=item B<o> HLStoRGB(Z<>)

=back

Z<>

=head2 1. Création de composants graphiques


=over

=item B<buildZincItem>(widget, parentgroup, options);

Creation d'items de representations Zinc.
Les objets graphiques generes peuvent etre complexes (geometrie, multi contours, 
operateur de forme, empilage d'items, reliefs, ombre portee, repetition, 
transformations...) mais sont decrits par des 
options geometriques ou de surfacage 2D 1/2 de haut niveau.

=over
    
=item B<Parametres> :

=over

=item B<widget>

<widget> identifiant du widget zinc.

=item B<parentgroup>

<tagOrId> identifiant de l'item group parent.


=back


=item B<Options> :

						      
=over

=item B<-itemtype> => type

Specifie le(s) type(s) d'item(s) souhaite(s). Peut etre celui d'un item
natif zinc (B<group>, B<rectangle>, B<arc>, B<curve>, B<text>, B<icon>),
ou un B<'metatype'> permettant de specifier des curves 'particulieres'. Les sections coniques
de ces metatypes (raccords ou arcs) seront simulees par des segments quadratiques de bezier. Ces metatypes sont :

=over

=item roundedrectangle

decrit par 2 cordonnees (haut-gauche et bas-droite du rectangle) et un rayon de raccord angulaire.
Une liste optionnelle de realisation des raccords [0 = sans raccord|1 = avec raccord] permet de specifier pour chaque angle le type de raccord
(angle ou arc).

=item hippodrome

decrit par 2 cordonnees (haut-gauche et bas-droite du rectangle englobant).
Si l'orientation n'est pas specifiee, le rayon de raccord sera egal a la moitie du plus petit cote .
Une liste optionnelle de realisation des raccords permet de specifier pour chaque angle le type de raccord
(angle ou arc).

=item ellipse

decrit par 2 cordonnees (haut-gauche et bas-droite du rectangle englobant).  
Une liste optionnelle de realisation des raccords permet de specifier pour chaque angle le type de raccord
(angle ou arc).

=item polygone

polygone regulier a n cotes, (triangle equilateral, carre, pentagone, hexagone...)
convexe ou en etoile. Le polygone sera inscrit dans un cercle dont le rayon est passe en parametres 
(un 2eme rayon 'interne' decrira un polygone etoile). Un rayon de raccord et une liste de realisation des raccords permettent 
des variantes interressantes.

=item roundedcurve

curve multicontours a coins arrondis, de rayon raccord unique,
pour specifier une forme quelconque.

=item polyline

curve multicontours a coins arrondis. Le rayon de chaque raccord pouvant etre defini
specifiquement.

=item pathline

creation d'une ligne multisegments 'epaisse',
realisee par 'decalage' par rapport a un path donne (largeur et sens de decalage
 [left|both|right] optionnels). Le contour transforme en surface avec l'item Zinc triangles
permet d'appliquer un degrade de couleurs le long du trace (lineaire, transversal ou double).

=back


=item B<-coords> => \@xy

<coords list> coordonnees geometriques ou de position de l'item.

=item B<-metacoords> => \%metatype_params

<hashtable> calcul des coordonnées de l'item par passage d'un [meta]type d'item
différent de celui décrit par -itemtype. (ex. un pathline défini par un polygone)

<coords list> coordonnees geometriques ou de position de l'item.

=item B<-params> => \%zinc_attr

<hashtable> parametres zinc de l'item.

=item B<-contours> => \@list

<contours list> arguments zinc d'ajout de contours .

=item B<-clip>

<coords list or hashtable> clipping d'un item group.

=item B<-items>

<hashtable> table d'items contenus dans un item group.
provoque un appel récursif de la fonction buildZincItem().

=item B<-texture>

<imagefile> ajout d'une texture a l'item.

=item B<-pattern>

<imagefile> ajout d'un pattern a l'item.

=item B<-relief>

<hash table> creation d'un relief a l'item a l'aide d'item zinc triangles.
Invoque la fonction du module Graphics graphicItemRelief()

=item B<-shadow>

<hash table> creation d'une ombre portee a l'item.
Invoque la fonction du module Graphics graphicItemShadow()

=item B<-repeat>

<hash table> repetition de l'item.
Invoque la fonction du module Graphics repeatZincItem()

=item B<-scale> => scale factor or [xscale, yscale] 

application d'une transformation zinc->scale a l'item

=item B<-translate> => [dx,dy]

 application d'une transformation zinc->translate a l'item

=item B<-rotate> => <angle> (en degré) 

application d'une transformation zinc->rotate a l'item

=item B<-addtags>

<tags list> liste de tags specifiques a ajouter aux parametre item -tags.

=item B<-name>

<string> nom de l'item.

=back
						      
=back

Z<>

=item B<repeatZincItem>(widget, item, options);

Répétition (clonage) d'un objet Zinc de representation.
    
=over

=item B<Parametres> :

=over

=item B<widget>

<widget> identifiant du widget zinc.

=item B<item>

<tagOrId> identifiant de l'item zinc a dupliquer.

=back

=item B<Options> :
						      
=over

=item B<-num> => integer

Nombre de répétitions.

=item B<-dxy> => [dx, dy]

Paramètres de translation a appliquer entre 2 copies.

=item B<-angle> => <angle>

angle de rotation en degré a appliquer entre 2 copies.

=item B<-copytag> => <tag name>

ajout d'un tag indexé pour chaque copie.

=item B<-params> => \%zinc_attr

Paramétrage specialises de chaque copie


=back

=back

Z<>

=item B<buildTabBoxItem>(widget, parentgroup, options);

Construit les items de représentation d'une boîte à onglets multi-pages. 
Le positionnement, la forme et la taille des onglets est définie automatiquement
ou spécifiés par options. L'ajout de titres aux pages est possible. Des tags
de base (intercalaires et titres) permettent de définir des interactions de 
sélection/navigation par bindings. 

=over
    
=item B<Parametres> :

=over

=item B<widget>

<widget> identifiant du widget zinc.

=item B<parentgroup>

<tagOrId> identifiant de l'item group parent.

=back

=item B<Options> :
						      
=over

=item B<-coords> => [[x0,y0],[x1,y1]]

<coords> coordonnées haut-gauche et bas-droite de la BoundingBox du tabBox.  

=item B<-numpages>

<integer> nombre de pages du TabBox.

=item B<-anchor> => 'n'|'e'|'s'|'w' 

ancrage nord, est, sud ou ouest des onglets (par défaut 'n')

=item B<-alignment> => 'left'|'center'|'right' 

alignement gauche, centré ou droit des onglets sur l'ancrage (par défaut left)

=item B<-tabwidth> => 'auto'|<dimension>|<dimensionList> 

longeur des onglets : 'auto' longeur répartie sur le coté, longeur absolue ou liste de longeurs
ces dimensions sont autoajustées si dépassement. (par défaut 'auto').

=item B<-tabheight> => 'auto'|<dimension> 

hauteur des onglets (par défaut 'auto')

=item B<-tabshift> => 'auto'|<dimension> 

offset de biseau entre la base et le haut de l'onglet (par défaut 'auto').

=item B<-overlap> => 'auto'|<dimension> 

offset de décalage entre 2 onglets (par défaut 'auto').

=item B<-radius>

<dimension> rayon des arrondis d'angle des onglets. (par défaut 0)

=item B<-corners> 

<booleanList> liste d'application du raccord aux angles sous forme booleenne 
0 = sans raccord 1 = avec raccord.

=item B<-params> => \%zinc_attr

<hashtable> parametres zinc de l'item.

=item B<-texture>

<imagefile> ajout d'une texture a l'item.

=item B<-relief>

<hash table> creation d'un relief pour les pages du tabBox.
Invoque la fonction du module Graphics graphicItemRelief()

=item B<-tabtitles>

<hashtable> table de hash de définition des titres d'onglets (label, params).

=item B<-pageitems>

<hashtable> table d'items 'complémentaire' à réaliser pour chaque page.
provoque un appel récursif de la fonction buildZincItem().


=back

=back

=back

Z<>

=head2 2. Calculs de formes géométriques complexes

=over

=item B<roundedRectangleCoords>(coords, options);

Retourne les coordonnées (curve) d'un rectangle à coins arrondis

=over

=item B<Parametres> :

=over

=item B<coords> => [[x0,y0],[x1,y1]]

<coordList> coordonnées haut-gauche et bas-droite du rectangle.

=back

=item B<Options> :
						      
=over

=item B<-radius>  

<dimension> rayon de raccord circulaire des angles.

=item B<-corners> => \@cornersList

Liste de réalisation des raccords de sommets [0 = pad de raccord (droit)| 1 = raccord circulaire].
(par défaut [1,1,1,1]).

=back

=back

Z<>

=item B<hippodromeCoords>(coords, options);

Retourne les coordonnées (curve) d'un hippodrome

=over

=item B<Parametres> :

=over

=item B<coords> => [[x0,y0],[x1,y1]]

<coordList> coordonnées haut-gauche et bas-droite du rectangle exinscrit à l'hippodrome.

=back

=item B<Options> :
						      
=over

=item B<-orientation>  => <horizontal|vertical>

orientation forcée de l'hippodrome (sinon hauteur = plus petit coté).

=item B<-corners> => \@cornersList

Liste de réalisation des raccords de sommets [0 = pad de raccord (droit)| 1 = raccord circulaire].
(par défaut [1,1,1,1]).

=item B<-trunc>  => <left|right|top|bottom|both>

troncatures des cotés circulaires de l'hippodrome.

=back

=back

Z<>

=item B<ellipseCoords>(coords, options);

Retourne les coordonnées (curve) d'une ellipse

=over

=item B<Parametres> :

=over

=item B<coords> => [[x0,y0],[x1,y1]]

<coordList> coordonnées haut-gauche et bas-droite du rectangle exinscrit.

=back

=item B<Options> :
						      
=over

=item B<-corners> => \@cornersList

Liste de réalisation des quadrants [0 = angle droit| 1 = raccord d'ellipse].
(par défaut [1,1,1,1]).

=back

=back

Z<>

=item B<roundedCurveCoords>(coords, options);

Retourne les coordonnées d'une curve à coins arrondis.

=over

=item B<Parametres> :

=over

=item B<coords> => [[x0,y0],...[xn,yn]]

<coordList> coordonnées de la curve

=back

=item B<Options> :
						      
=over

B<-radius> : <dimension> 
rayon de raccord des angles. par defaut 0

B<-corners> : <booleanList> 
liste d'application du raccord circulaire aux angles sous forme booleenne 
0 = sans raccord 1 = avec raccord. par defaut [1,1,...,1].

=back

=back

Z<>

=item B<polygonCoords>(coords, options);

Retourne les coordonnées d'un polygone régulier à n cotés ou d'une étoile à
n branches. Le polygone sera inscrit dans un cercle de rayon -radius, un 2ème
rayon interne décrira les sommets interne de l'étoile. Raccords circulaires
optionnels des sommets du polygone/étoile

=over

=item B<Parametres> :

=over

=item B<coords> => [x0,y0]

<coords> coordonnées du centre du cercle exinscrit au polygone/étoile

=back

=item B<Options> :
						      
=over

B<-numsides> : <dimension> nombre de cote du polygone ou nombre de branches de l'etoile

B<-radius> : <dimension> rayon du cercle exinscrit au polygone

B<-startangle> : <angle> angle de depart du trace de la figure

B<-inner_radius> : <dimension> rayon du cercle des points 'internes' de l'etoile

B<-corner_radius> : <dimension> rayon des raccords d'angles

B<-corners> : <booleanList> liste d'application du raccord aux angles sous forme booleenne 
0 = sans raccord 1 = avec raccord. par defaut [1,1,1,1].

=back

=back

Z<>

=item B<polylineCoords>(coords, options);

Retourne les coordonnées d'une polyline, ligne 'brisée' multi-segments
avec raccords angulaires optionnels.

=over

=item B<Parametres> :

=over

=item B<coords> => [[x0,y0],...[xn,yn]]

<coordList> liste de coordonnées des sommets de la polyline

=back

=item B<Options> :
						      
=over

B<-radius> : <dimension> 
rayon global de raccord des angles. par defaut 0

B<-corners> : <booleanList> 
liste d'application du raccord circulaire aux angles sous forme booleenne 
0 = sans raccord 1 = avec raccord. par defaut [1,1,...,1].

B<-corners_radius> : <dimensionList> 
Liste des rayons de raccord des angles.

=back

=back

Z<>

=item B<curveLineCoords>(coords, options);

ATTENTION FONCTION EN CHANTIER 

Retourne les coordonnées curve (de surface) d'un stroke. la ligne est décrite 
le long d'un chemin et dessinée selon les attributs graphiques classiques 'stroke'
(style d'épaisseur, d'extremité, de jointure, de tiret...)

=over

=item B<Parametres> :

=over

=item B<coords> => [[x0,y0],...[xn,yn]]

<coordList> coordonnées de la curve

=back

=item B<Options> :
						      
=over

B<-width> : <dimension> 
épaisseur de la ligne. par defaut 1

B<-linecap> : <'butt'|'round'|'square'> 
Forme des extrémités des tracés ouverts.

B<-linejoin> : <'miter'|'round'|'bevel'> 
Forme des sommets des tracés.

B<-dasharray> : <'none'|motifList> 
Spécification du tireté : none (aucun) ou liste de longueurs tiret,[espace],[tiret]...
permettant de définir le dessin du tireté (par défaut none)

B<-dashoffset> : <dimension> 
distance décalage de départ dans le dessin du tireté (par défaut 0)

=back

=back

Z<>

=item B<pathLineCoords>(coords, %options);

retourne les coordonnées (triangles) d'une ligne multisegments 'epaisse',
realisee par 'décalage' par rapport à un path donné (largeur et sens de décalage
 [out|center|in] optionnels).

=over

=item B<Parametres> :

=over

=item B<coords> => [[x0,y0],...[xn,yn]]

<coordList> liste de coordonnées du path

=back

=item B<Options> :
						      
=over

B<-closed> : <boolean> 
fermeture du tracé. par defaut 0

B<-shifting> : <'out'|'center'|'in'> 
sens de décalage de l'épaisseur de contour : 'center' (1/2 décalage de chaque coté du path) 'out' (décalage externe) 'in' (décalage interne) par défaut 'center'.

B<-width> : <dimension> 
Largeur du décalage de ligne (par défaut 2).

=back

=back

Z<>

=item B<shiftPathCoords>(coords, %options);

retourne les coordonnées curve de 'décalage' par rapport à un path donné.

=over

=item B<Parametres> :

=over

=item B<coords> => [[x0,y0],...[xn,yn]]

<coordList> liste de coordonnées du path

=back

=item B<Options> :
						      
=over

B<-closed> : <boolean> 
fermeture du tracé. par defaut 0

B<-shifting> : <'out'|'in'> 
sens de décalage du path : 'out' (décalage externe) 'in' (décalage interne) par défaut 'out'.

B<-width> : <dimension> 
Largeur du décalage de ligne (par défaut 1).

=back

=back

Z<>

=item B<tabBoxCoords>(coords, options);

Retourne les coordonnées de construction d'un TabBox (boîte à onglets) : liste de curve décrivant les 'pages' du TabBox et coordonnées de position des titres onglets. 

=over

=item B<Parametres> :

=over

=item B<coords> => [[x0,y0],[x1,y1]]

<coords> coordonnées haut-gauche et bas-droite de la BoundingBox du tabBox.  

=back

=item B<Options> :
						      
=over

B<-numpages> : <integer> nombre de pages du TabBox.

B<-anchor> : <'n'|'e'|'s'|'w'> ancrage nord, est, sud ou ouest des onglets (par défaut 'n')

B<-alignment> : <'left'|'center'|'right'> alignement gauche, centré ou droit des onglets sur l'ancrage (par défaut left)

B<-tabwidth> : 'auto'|<dimension|dimensionList> longeur des onglets : 'auto' longeur répartie sur le coté, longeur absolue ou liste de longeurs
ces dimensions sont autoajustées si dépassement. (par défaut 'auto').

B<-tabheight> : 'auto'|<dimension> hauteur des onglets (par défaut 'auto')

B<-tabshift> : 'auto'<dimension> offset de biseau entre la base et le haut de l'onglet (par défaut 'auto').

B<-overlap> : 'auto'<dimension> offset de décalage entre 2 onglets (par défaut 'auto').

B<-radius> : <dimension> 
rayon des arrondis d'angle des onglets. (par défaut 0)

B<-corners> : <booleanList> liste d'application du raccord aux angles sous forme booleenne 
0 = sans raccord 1 = avec raccord.

=back

=back

=back

Z<>

=head2 3. Création de reliefs et ombre portée

Z<>

=over

=item B<graphicItemRelief>(widget, item, %options);

Construit un relief à l'item géometrique 
(qui peut etre multicontours) en utilisant des items zinc triangles.
Ce relief de type 'embossage' de forme possede un
profil (flat ou rounded) et dérive en luminosite la couleur dominante
de l'item (ou une couleur donnée) suivant l'orientation d'éclairage global zinc
-lighangle (ou un angle de lumière donné).  

=over
    
=item B<Parametres> :

=over

=item B<widget>

identifiant du widget zinc.

=item B<item>

identifiant de l'item zinc à mettre en relief.

=back

=item B<Options> :
						      
=over

B<-closed> : <boolean> fermeture (de forme) du relief (par défaut 1).

B<-profil> : <'flat'|'rounded'> type de profil du relief (par défaut 'rounded').

B<-relief> : <'raised'|'sunken'> sens de l'embossage (par defaut 'raised').

B<-side> : <outside|inside> position externe ou interne du relief (defaut 'inside').

B<-color> : <color> couleur de base du relief (défaut couleur dominante de l'item).

B<-smoothed> : <boolean> lissage des 'facettes' du relief (par defaut 1).

B<-lightangle> : <angle> angle de la lumiere (par defaut attribut -lightangle du widget).

B<-width> : <dimension> largeur du 'contour' relief.

B<-fine> : <boolean> mode precision courbe de bezier (par defaut 0 : auto-ajustee).

=back

=back

Z<>

=item B<graphicItemShadow>(widget, item, %options);

Cree une ombre portee a l'item geometrique 
(qui peut etre multicontours) en utilisant des items zinc triangles et curve.
Cette ombre correspond a une projection de la forme en fonction
d'une distance (par defaut 10) d'une orientation lumineuse (par defaut la valeur
globale -lightangle du widget) et d'un 'grossissement' (par defaut 0).
Une largeur 'width' de perimetre de diffusion/diffraction lumineuse (par defaut 4) 
qui permet de lisser le passage de l'ombre au fond, une couleur (par defaut black) 
et une opacite (par defaut 50) completent la specification.

=over

B<Parametres> : 

=over

B<widget> : <widget> identifiant du widget zinc

B<item> : <tagOrId> identifiant de l'item zinc

=back

B<Options> :

=over

B<-opacity> : <percent> poucentage d'opacite de l'ombre (par defaut 50).

B<-distance> : <dimension> distance de projection de l'ombre (par defaut 10).

B<-enlarging> : <dimension> 'grossissement' cone de projection (defaut 0).

B<-color> : <color> couleur de l'ombre (par defaut black).

B<-lightangle> : <angle> angle de la lumiere (par defaut attribut -lightangle du widget).

B<-width> : <dimension> largeur du perimetre de diffusion/diffraction (par defaut 4).

=back

=back

=back

Z<>

=head2 4. Fonctions géométriques de base

Z<>

=over

=item B<perpendicularPoint>(point, line);

retourne les coordonnées du point perpendiculaire abaissé d'un point sur une ligne.

=over

=item B<Parametres> :

=over

=item B<point> => [x, y]

<coords> coordonnées du point de référence.

=item B<line> => [[x0, y0],[x1, y1]]

<coordsList> liste de coordonnées des deux points de la ligne de référence.

=back

=back

Z<>


=item B<lineAngle>(startpoint, endpoint);

retourne l'angle formée par un vecteur, s'utilise aussi pour connaitre l'angle 'circulaire' 
d'un point par rapport à un centre de référence.

=over

=item B<Parametres> :

=over

=item B<startpoint> => [x, y]

<coords> coordonnées du point de départ du segment (ou centre de référence).

=item B<endpoint> => [x, y]

<coords> coordonnées du point de fin du segment (ou point 'circulaire' de référence).

=back

=back

Z<>

=item B<lineNormal>(startpoint, endpoint);

retourne la valeur d'angle perpendiculaire à un vecteur (utilisée par exemple 
pour mesurer l'incidence de lumière d'une facette). 

=over

=item B<Parametres> :

=over

=item B<startpoint> => [x, y]

<coords> coordonnées du point de départ du segment (ou centre de référence).

=item B<endpoint> => [x, y]

<coords> coordonnées du point de fin du segment (ou point 'circulaire' de référence).

=back

=back

Z<>

=item B<vertexAngle>(point0, point1, point2);

retourne la valeur de l'angle formé par trois points ainsi que la valeur d'angle
de la bisectrice de l'angle (fonction utilisé pour les calculs de décalages de path.

=over

=item B<Parametres> :

=over

=item B<point0> => [x, y]

<coords> coordonnées du premier point de définition de l'angle.

=item B<point1> => [x, y]

<coords> coordonnées du deuxième point de définition de l'angle (sommet).

=item B<point2> => [x, y]

<coords> coordonnées du troisième point de définition de l'angle.


=back

=back

Z<>

=item B<arc_pts>(center, radius, %options);

Calcul des points constitutifs d'un arc

=over 

=item B<Parametres> :

=over

=item B<center> => [x0,y0]

<coords> coordonnées du centre de l'arc.

=item B<radius>  

<dimension> rayon de l'arc.

=back

=item B<Options> :
						      
=over

=item B<-angle>  

<angle> angle de départ (en degré) de l'arc (par défaut 0)

=item B<-extent>  

<angle> delta angulaire (en degré) de l'arc (par défaut 360)

=item B<-step>

<angle> pas de progression angulaire (en degré) de calcul des points (par défaut 10).

=back

=back

Z<>

=item B<rad_point>(center, radius, angle);

Retourne le point circulaire défini par centre-rayon-angle.

=over

=item B<Parametres> :

=over

=item B<center> => [x0,y0]

<coords> coordonnées du centre de l'arc.

=item B<radius>  

<dimension> rayon de l'arc.

=item B<angle>  

<angle> angle (en degré) du point de circonférence avec le centre du cercle.

=back

=back

Z<>

=item B<bezierSegment>(coords, %options);

Calcul d'une approximation de segment (Quadratique ou Cubique) de bezier.

=over 

=item B<Parametres> :

=over

=item B<coords>

<coordsList> Liste de coordonnées des points définissant le segment de bezier.

=back

=item B<Options> :
						      
=over

=item B<-tunits>  

<integer> nombre pas de division des segments bezier (par défaut 20)

=item B<-skipend>  

<boolean> ne pas retourner le dernier point du segment (pour chaînage de segments).

=back

=back

Z<>

=item B<bezierPoint>(t, coords);

Calcul d'un point du segment (Quadratique ou Cubique) de bezier.
t représentation du temps (de 0 à 1). 
coords = (P1, C1, <C1>, P2) liste des points définissant le segment de bezier
P1 et P2 : extémités du segment et pts situés sur la courbe
C1 <C2> : point(s) de contrôle du segment

courbe bezier niveau 2 sur (P1, P2, P3)   P(t) = (1-t)²P1 + 2t(1-t)P2 + t²P3

courbe bezier niveau 3 sur (P1, P2, P3, P4)  P(t) = (1-t)³P1 + 3t(1-t)²P2 + 3t²(1-t)P3 + t³P4

=over 

=item B<Parametres> :

=over

=item B<t>

<pourcent> (de 0 à 1) représentation du temps.

=item B<coords>

<coordsList> Liste de coordonnées des points définissant le segment de bezier.

=back

=back

Z<>


=item B<bezierCompute>(coords, %options);

Calcul d'une approximation auto-ajustée de segment (Quadratique ou Cubique) de bezier.
l'approximation se fait par subdivision successive de la courbe jusqu'à atteindre une
distance avec la courbe théorique <= à la précision passée par option (par défaut 0.2).

=over 

=item B<Parametres> :

=over

=item B<coords>

<coordsList> Liste de coordonnées des points définissant le segment de bezier.

=back

=item B<Options> :
						      
=over

=item B<-precision>  

<dimension> seuil limite du calcul d'approche de la courbe (par défaut .2)

=item B<-skipend>  

<boolean> ne pas retourner le dernier point du segment (pour chaînage de segments).

=back

=back

=back

Z<>

=head2 5. Gestion des ressources images

Z<>

=over

=item B<getPattern>(filename, %options);

retourne et partage la ressource image bitmap en l'initialisant et la stockant si première utilisation.

=over

=item B<Parametres> :

=over

=item B<filename>

<image filename> non du fichier bitmap pattern

=back

=item B<Options> :
						      
=over

=item B<-storage>  

<hashtable> référence de la table de stockage privée des patterns.

=back

=back

Z<>

=item B<getTexture>(widget, filename, %options);

retourne et partage la ressource image texture en l'initialisant et la stockant si première utilisation.

=over

=item B<Parametres> :

=over

=item B<widget>

<widget> identifiant du widget zinc.

=item B<filename>

<imagefile> non du fichier image texture

=back

=item B<Options> :
						      
=over

=item B<-storage>  

<hashtable> référence de la table de stockage privée des textures.

=back

=back

Z<>

=item B<getImage>(widget, filename, %options);

retourne et partage la ressource image en l'initialisant et la stockant si première utilisation.

=over

=item B<Parametres> :

=over

=item B<widget>

<widget> identifiant du widget zinc.

=item B<filename>

<imagefile> non du fichier image

=back

=item B<Options> :
						      
=over

=item B<-storage>  

<hashtable> référence de la table de stockage privée des images.

=back

=back

Z<>

=item B<init_pixmaps>(widget, filenames, %options);

Initialise et stocke un ensemble d'images.

=over

=item B<Parametres> :

=over

=item B<widget>

<widget> identifiant du widget zinc.

=item B<filenames>

<imagefileList> Liste des fichier images à initialiser.

=back

=item B<Options> :
						      
=over

=item B<-storage>  

<hashtable> référence de la table de stockage privée des images.

=back

=back

=back

Z<>

=head2 6. Gestion des couleurs

Z<>

=over

=item B<setGradients>(widget, gradients);

Création de gradiants nommés Zinc

=over

=item B<Parametres> :

=over

=item B<widget>

<widget> identifiant du widget Zinc

=item B<gradients>  

<hashtable> référence de la table de définition des gradiants zinc ('non' => 'zincGradient').

=back

=back

Z<>

=item B<zincItemPredominantColor>(widget, item);

retourne la couleur dominante d'un item ('barycentre' gradiant fillcolor).

=over

=item B<Parametres> :

=over

=item B<widget>

<widget> identifiant du widget Zinc

=item B<item>  

<tagOrId>  identifiant de l'item zinc.

=back

=back

Z<>

=item B<medianColor>(color1, color2, rate);

calcul d'une couleur intermédiaire défini par un ratio ($rate) entre 2 couleurs.

=over

=item B<Parametres> :

=over

=item B<color1>

<color> première couleur

=item B<color2>  

<color> première couleur

=item B<rate>

<pourcent> (de 0 à 1) position de la couleur intermédiaire.

=back

=back

Z<>

=item B<createGraduate>(widget, steps, refcolors, repeat);

création d'un jeu de couleurs intermédiaires (dégradé) entre n couleurs.

=over

=item B<Parametres> :

=over

=item B<widget>

<widget> identifiant du widget Zinc

=item B<steps>  

<integer> nombre totale de couleurs retournées.

=item B<refcolors>  

<colorList> liste de couleurs servant à créer le dégradé.

=item B<repeat>  

<integer> répétition de chaque couleur utilisé par exemple pour triangles path
où la couleur est répétée 2 fois (par défaut 1).

=back

=back

Z<>

=item B<lightingColor>(color, newL);

Modification d'une couleur par sa composante luminosité (exemple relief).

=over

=item B<Parametres> :

=over

=item B<color>

<color> couleur au format zinc.

=item B<newL>

<pourcent> (de 0 à 1) nouvelle valeur de luminosité.

=back

=back

Z<>

=item B<ZnColorToRGB>(zncolor);

conversion d'une couleur Zinc hexa au format RGBA (255,255,255,100).

=over

=item B<Parametres> :

=over

=item B<zncolor>

<color> couleur au format hexa zinc (#ffffff ou #ffffffffffff).

=back

=back

Z<>

=item B<RGBtoLCH>(r, g, b);

conversion d'une couleur de l'espace RGB à l'espace CIE LCH°.

=over

=item B<Parametres> :

=over

=item B<r>

<pourcent> (de 0 à 1) valeur de la composante rouge de la couleur RGB.

=item B<g>

<pourcent> (de 0 à 1) valeur de la composante verte de la couleur RGB.

=item B<b>

<pourcent> (de 0 à 1) valeur de la composante bleue de la couleur RGB.

=back

=back

Z<>

=item B<LCHtoRGB>(L, C, H);

conversion d'une couleur de l'espace CIE LCH° à l'espace RGB.

=over

=item B<Parametres> :

=over

=item B<L>

<pourcent> (de 0 à 1) valeur de la composante luminosité de la couleur CIE LCH.

=item B<C>

C : <pourcent> (de 0 à 1) valeur de la composante saturation de la couleur CIE LCH

=item B<H>

H : <pourcent> (de 0 à 1) valeur de la composante teinte de la couleur CIE LCH

=back

=back

Z<>

=item B<RGBtoHLS>(r, g, b);

conversion d'une couleur de l'espace RGB à l'espace HLS.

=over

=item B<Parametres> :

=over

=item B<r>

<pourcent> (de 0 à 1) valeur de la composante rouge de la couleur RGB.

=item B<g>

<pourcent> (de 0 à 1) valeur de la composante verte de la couleur RGB.

=item B<b>

<pourcent> (de 0 à 1) valeur de la composante bleue de la couleur RGB.

=back

=back

Z<>

=item B<HLStoRGB>(H, L, S);

conversion d'une couleur de l'espace HLS à l'espace RGB.

=over

=item B<Parametres> :

=over

=item B<H>

<pourcent> (de 0 à 1) valeur de la composante teinte de la couleur HLS.

=item B<L>

C : <pourcent> (de 0 à 1) valeur de la composante luminosité de la couleur HLS.

=item B<S>

H : <pourcent> (de 0 à 1) valeur de la composante saturation de la couleur HLS.

=back

=back

Z<>

=item B<hexaRGBcolor>(r, g, b, a);

conversion d'une couleur RGBA (255,255,255,100) au format Zinc '#ffffff'.

=over

=item B<Parametres> :

=over

=item B<r>

<colorComposant> (0 à 255) composante rouge de la couleur rgba.

=item B<g>

<colorComposant> (0 à 255) composante verte de la couleur rgba.

=item B<b>

<colorComposant> (0 à 255) composante bleue de la couleur rgba.

=item B<a>

<colorComposant> (0 à 255) composante alpha de la couleur rgba.

=back

=back

Z<>

=back

Z<>


=head1 EXEMPLE

my %gradset = (
   'gdlens' => '=radial -15 -20|#ffb7b7;70|#bd6622;90',
   'gdstar' => '=radial -15 -20|#ffb7b7;50|#bd6622;90');

my %starstyle => (
       # table hash parametres et options
       -itemtype => 'group',
       -coords => [250, 250],
       -params => {-priority => 90,
                   -tags => ['starlens', 'move'],
                   -sensitive => 1,
                   -atomic => 1,
                   },
       -items => {
           'lens' => {-itemtype => 'hippodrome',
                      -coords => [[-200, -200],
                                  [200, 200]],
                      -params => {-closed => 1,
                                  -filled => 1,
                                  -fillcolor => 'gdlens',
                                  -linewidth => 1.5,
                                  -linecolor => '#440000',
                                  -priority => 10,
                                 },
                      -relief => {-width => 14,
                                  -profil => 'rounded',
                                  -lightangle => 135,
                                  },
                      -shadow => {-distance => 20,
                                  -width => 18,
                                  -lightangle => 135,
                                  -opacity => 40,
                                  -enlarging => 6,
                                 },
                      },
          'star' => {-itemtype => 'polygone',
                     -coords => [0, 0],
                     -numsides => 5,
                     -radius => 180,
                     -inner_radius => 70,
                     -corner_radius => 10,
                     -startangle => 270,
                     -corners => [0,1,0,1,0,1,0,1,0,1],
                     -params => {-filled => 1,
                                 -fillcolor => 'gradstar',
                                 -linewidth => 1,
                                 -linecolor => '#330000',
                                 -priority => 20,
                                },
                     -relief => {-width => 10,
                                 -profil => 'rounded',
                                 -side => 'outside',
                                 -relief => 'sunken',
                                },
                     },
             },
       );


&setGradients($widget, \%gradset);

my $star = &buildZincItem($zinc, $topgroup, \%starstyle);

=head1 AUTEURS

Jean-Luc Vinot <vinot@cena.fr>