From e6a05dbef707dc10e546ef8fef8fc2a8b7d805bf Mon Sep 17 00:00:00 2001 From: cvs2svn Date: Mon, 24 Jan 2005 15:46:33 +0000 Subject: This commit was manufactured by cvs2svn to create branch 'POSTSCRIPT'. --- .cvsignore | 17 - BUGS | 16 - Copyright | 17 - Makefile.in | 520 -- Perl/.cvsignore | 5 - Perl/Makefile.PL.in | 140 - Perl/README | 81 - Perl/Zinc.pm.in | 157 - Perl/Zinc.xs | 59 - Perl/Zinc/Debug.pm | 3023 ------------ Perl/Zinc/Graphics.pm | 3067 ------------ Perl/Zinc/Graphics.pod | 1749 ------- Perl/Zinc/Logo.pm | 238 - Perl/Zinc/Text.pm | 262 - Perl/Zinc/Trace.pm | 227 - Perl/Zinc/TraceErrors.pm | 149 - Perl/Zinc/TraceUtils.pm | 111 - Perl/debug/.cvsignore | 4 - Perl/demos/.cvsignore | 2 - Perl/demos/Makefile.PL | 7 - Perl/demos/Tk/demos/zinc_contrib_lib/README | 1 - .../demos/zinc_contrib_lib/TripleRotatingWheel.pl | 445 -- .../Tk/demos/zinc_data/background_texture.gif | Bin 19979 -> 0 bytes .../Tk/demos/zinc_data/hegias_parouest_TE.vid | Bin 9216 -> 0 bytes Perl/demos/Tk/demos/zinc_data/paper-grey.gif | Bin 1540 -> 0 bytes Perl/demos/Tk/demos/zinc_data/paper-grey1.gif | Bin 1540 -> 0 bytes Perl/demos/Tk/demos/zinc_data/paper.gif | Bin 1529 -> 0 bytes Perl/demos/Tk/demos/zinc_data/stripped_texture.gif | Bin 123 -> 0 bytes Perl/demos/Tk/demos/zinc_data/videomap_orly | Bin 67584 -> 0 bytes .../demos/Tk/demos/zinc_data/videomap_paris-w_90_2 | Bin 8192 -> 0 bytes Perl/demos/Tk/demos/zinc_data/zinc.gif | Bin 793 -> 0 bytes Perl/demos/Tk/demos/zinc_data/zinc_anti.gif | Bin 1461 -> 0 bytes Perl/demos/Tk/demos/zinc_lib/MagicLens.pl | 325 -- Perl/demos/Tk/demos/zinc_lib/Zetris.pl | 972 ---- Perl/demos/Tk/demos/zinc_lib/all_options.pl | 154 - Perl/demos/Tk/demos/zinc_lib/atomic-groups.pl | 221 - Perl/demos/Tk/demos/zinc_lib/clipping.pl | 150 - Perl/demos/Tk/demos/zinc_lib/color-circular.pl | 75 - .../Tk/demos/zinc_lib/color-path-and-conic.pl | 78 - Perl/demos/Tk/demos/zinc_lib/color-x.pl | 94 - Perl/demos/Tk/demos/zinc_lib/color-y.pl | 91 - Perl/demos/Tk/demos/zinc_lib/contours.pl | 202 - Perl/demos/Tk/demos/zinc_lib/counter.pl | 440 -- Perl/demos/Tk/demos/zinc_lib/curve_bezier.pl | 221 - Perl/demos/Tk/demos/zinc_lib/fillrule.pl | 101 - .../Tk/demos/zinc_lib/groups_in_ATC_strips.pl | 910 ---- Perl/demos/Tk/demos/zinc_lib/groups_priority.pl | 261 - Perl/demos/Tk/demos/zinc_lib/icon_zoom_resize.pl | 157 - Perl/demos/Tk/demos/zinc_lib/items.pl | 187 - Perl/demos/Tk/demos/zinc_lib/labelformat.pl | 111 - Perl/demos/Tk/demos/zinc_lib/lines.pl | 96 - Perl/demos/Tk/demos/zinc_lib/mapinfo.pl | 130 - Perl/demos/Tk/demos/zinc_lib/path_tags.pl | 357 -- Perl/demos/Tk/demos/zinc_lib/rotation.pl | 124 - .../Tk/demos/zinc_lib/simple_interaction_track.pl | 269 -- Perl/demos/Tk/demos/zinc_lib/simpleradar.pl | 489 -- Perl/demos/Tk/demos/zinc_lib/testGraphics.pl | 1845 ------- Perl/demos/Tk/demos/zinc_lib/textInput.pl | 98 - Perl/demos/Tk/demos/zinc_lib/tiger.pl | 554 --- Perl/demos/Tk/demos/zinc_lib/tkZincLogo.pl | 165 - Perl/demos/Tk/demos/zinc_lib/transforms.pl | 568 --- Perl/demos/Tk/demos/zinc_lib/translation.pl | 144 - Perl/demos/Tk/demos/zinc_lib/triangles.pl | 58 - Perl/demos/Tk/demos/zinc_lib/wheelOfFortune.pl | 374 -- Perl/demos/Tk/demos/zinc_lib/window-contours.pl | 112 - Perl/demos/Tk/demos/zinc_lib/zoom.pl | 180 - Perl/demos/Tk/demos/zinc_pm/SimpleRadarControls.pm | 235 - Perl/demos/t/no-test.t | 8 - Perl/demos/zinc-demos | 502 -- Perl/export2cpan | 173 - Perl/t/.cvsignore | 2 - Perl/t/AnimatedGradient.t | 175 - Perl/t/Bbox.t | 242 - Perl/t/Coords.t | 151 - Perl/t/Images.t | 212 - Perl/t/Import.t | 31 - Perl/t/PreviousKnownBugs.t | 61 - Perl/t/Test/Builder.pm | 1408 ------ Perl/t/Test/Harness.pm | 1168 ----- Perl/t/Test/Harness/Assert.pm | 68 - Perl/t/Test/Harness/Iterator.pm | 61 - Perl/t/Test/Harness/Straps.pm | 667 --- Perl/t/Test/More.pm | 1248 ----- Perl/t/TestLog.pm | 306 -- Perl/t/Text.t | 58 - Perl/t/Transformations.t | 304 -- Perl/t/find.t | 200 - Perl/t/test-methods.pl | 689 --- Perl/t/test-no-crash.pl | 880 ---- Perl/t/testdoc.pl | 274 -- Perl/t/text.t | 161 - Perl/t/traceutils.t | 89 - Python/library/Zinc.py.in | 452 -- README | 294 -- aclocal.m4 | 171 - bootstrap | 3 - buildperl.tcl | 40 - configure | 4656 ------------------ configure.in | 236 - debian/.cvsignore | 8 - debian/README.debian | 6 - debian/changelog | 1374 ------ debian/control | 39 - debian/copyright | 22 - debian/rules | 125 - debian/zinc-python.postinst | 23 - debian/zinc-python.prerm | 11 - demos/allOptions.tcl | 121 - demos/atomicGroups.tcl | 184 - demos/clipping.tcl | 123 - demos/colorCircular.tcl | 63 - demos/colorX.tcl | 48 - demos/colorY.tcl | 48 - demos/contours.tcl | 202 - demos/curveBezier.tcl | 265 -- demos/data/hegias_parouest_TE.vid | Bin 9216 -> 0 bytes demos/data/videomap_orly | Bin 67584 -> 0 bytes demos/data/videomap_paris-w_90_2 | Bin 8192 -> 0 bytes demos/fillRule.tcl | 105 - demos/groupsInAtcStrips.tcl | 902 ---- demos/groupsPriority.tcl | 250 - demos/iconTransform.tcl | 157 - demos/images/background_texture.gif | Bin 19979 -> 0 bytes demos/images/paper-grey.gif | Bin 1540 -> 0 bytes demos/images/paper-grey1.gif | Bin 1540 -> 0 bytes demos/images/paper.gif | Bin 1529 -> 0 bytes demos/images/photoAlpha.png | Bin 77053 -> 0 bytes demos/images/stripped_texture.gif | Bin 123 -> 0 bytes demos/images/zinc.gif | Bin 1461 -> 0 bytes demos/items.tcl | 144 - demos/labelformat.tcl | 86 - demos/lines.tcl | 58 - demos/magicLens.tcl | 306 -- demos/pathTags.tcl | 319 -- demos/photoAlpha.tcl | 162 - demos/reliefs.tcl | 278 -- demos/simpleInteractionTrack.tcl | 232 - demos/simpleRadar.tcl | 403 -- demos/testGraphics.tcl | 2130 --------- demos/textInput.tcl | 80 - demos/tiger.tcl | 605 --- demos/tkZincLogo.tcl | 168 - demos/transforms.tcl | 506 -- demos/triangles.tcl | 48 - demos/windowContours.tcl | 92 - demos/zinc-widget | 331 -- doc/.cvsignore | 19 - doc/alledges.png | Bin 1684 -> 0 bytes doc/allgradients.png | Bin 11103 -> 0 bytes doc/alllineshapes.png | Bin 2672 -> 0 bytes doc/allreliefs.png | Bin 4878 -> 0 bytes doc/alphastip.png | Bin 4154 -> 0 bytes doc/atcsymb.png | Bin 2206 -> 0 bytes doc/fillrule.png | Bin 7404 -> 0 bytes doc/refman.tex | 4914 ------------------- doc/tabularexample.png | Bin 456 -> 0 bytes doc/textthroughholes.png | Bin 6309 -> 0 bytes doc/tkzinclogo.png | Bin 13451 -> 0 bytes doc/trackexample.png | Bin 2626 -> 0 bytes doc/waypointexample.png | Bin 987 -> 0 bytes library/pkgIndex.tcl | 13 - library/zincGraphics.tcl | 1322 ----- library/zincLogo.tcl | 107 - library/zincText.tcl | 191 - libtess/GL/gl.h | 2585 ---------- libtess/GL/glext.h | 5024 -------------------- libtess/Imakefile | 60 - libtess/README | 447 -- libtess/alg-outline | 229 - libtess/dict-list.h | 107 - libtess/dict.c | 117 - libtess/dict.h | 107 - libtess/geom.c | 271 -- libtess/geom.h | 90 - libtess/glu.h | 325 -- libtess/gluos.h | 50 - libtess/libtess_la_SOURCES | 27 - libtess/memalloc.c | 62 - libtess/memalloc.h | 65 - libtess/mesh.c | 796 ---- libtess/mesh.h | 273 -- libtess/normal.c | 259 - libtess/normal.h | 52 - libtess/priorityq-heap.c | 259 - libtess/priorityq-heap.h | 114 - libtess/priorityq-sort.h | 124 - libtess/priorityq.c | 267 -- libtess/priorityq.h | 124 - libtess/render.c | 505 -- libtess/render.h | 59 - libtess/sweep.c | 1362 ------ libtess/sweep.h | 84 - libtess/tess.c | 634 --- libtess/tess.h | 180 - libtess/tessmono.c | 208 - libtess/tessmono.h | 78 - redhat/changelog | 108 - redhat/perl-Tk-Zinc.spec | 148 - redhat/rules | 31 - sandbox/Controls.pm | 224 - sandbox/alledges.pl | 47 - sandbox/allgradients.pl | 64 - sandbox/allgradients.tcl | 48 - sandbox/alllineshapes.pl | 47 - sandbox/allreliefs.pl | 54 - sandbox/allreliefs.tcl | 30 - sandbox/bouton-down.xpm | 342 -- sandbox/bouton.xpm | 329 -- sandbox/conical.tcl | 18 - sandbox/contours.tcl | 45 - sandbox/controls.tcl | 158 - sandbox/defs.tcl | 1097 ----- sandbox/fvwm.xbm | 21 - sandbox/lines.pl | 35 - sandbox/logo.gif | Bin 402 -> 0 bytes sandbox/smooth.tcl | 34 - sandbox/testarc.tcl | 44 - sandbox/testbezier.pl | 190 - sandbox/testbezier.tcl | 131 - sandbox/testbitmaps.tcl | 86 - sandbox/testicon.tcl | 102 - sandbox/testplug.pl | 51 - sandbox/testpoly.tcl | 157 - sandbox/testrect.pl | 99 - sandbox/testrelief.pl | 73 - sandbox/testrelief.tcl | 45 - sandbox/testshape.pl | 132 - sandbox/testshape.tcl | 18 - sandbox/testtext.tcl | 138 - sandbox/testwind.tcl | 19 - sandbox/testzinc.pl | 503 -- sandbox/textexpand.tcl | 6 - sandbox/texture-bois1.xpm | 320 -- sandbox/texture-paper.xpm | 87 - sandbox/trash.xbm | 6 - sandbox/triangles.pl | 69 - sandbox/xpenguin.png | Bin 10148 -> 0 bytes sandbox/zinc.tcl | 284 -- sandbox/zinc.test | 154 - starkit.tcl.in | 203 - starkit/demo.tcl | 4 - starkit/main.tcl | 35 - tclconfig/README.txt | 26 - tclconfig/install-sh | 119 - tclconfig/tcl.m4 | 3179 ------------- tests/all.tcl | 8 - tests/rectangle.test | 48 - tkzinc.m4 | 170 - win/Tkzinc.aip.in | 118 - win/Tkzincperl.aip.in | 151 - win/WinPort.c | 1042 ---- win/makefile.vc.in | 130 - win/package.tcl | 76 - 253 files changed, 78272 deletions(-) delete mode 100644 .cvsignore delete mode 100644 BUGS delete mode 100644 Copyright delete mode 100644 Makefile.in delete mode 100644 Perl/.cvsignore delete mode 100644 Perl/Makefile.PL.in delete mode 100644 Perl/README delete mode 100644 Perl/Zinc.pm.in delete mode 100644 Perl/Zinc.xs delete mode 100644 Perl/Zinc/Debug.pm delete mode 100644 Perl/Zinc/Graphics.pm delete mode 100644 Perl/Zinc/Graphics.pod delete mode 100644 Perl/Zinc/Logo.pm delete mode 100644 Perl/Zinc/Text.pm delete mode 100644 Perl/Zinc/Trace.pm delete mode 100644 Perl/Zinc/TraceErrors.pm delete mode 100644 Perl/Zinc/TraceUtils.pm delete mode 100644 Perl/debug/.cvsignore delete mode 100644 Perl/demos/.cvsignore delete mode 100644 Perl/demos/Makefile.PL delete mode 100644 Perl/demos/Tk/demos/zinc_contrib_lib/README delete mode 100644 Perl/demos/Tk/demos/zinc_contrib_lib/TripleRotatingWheel.pl delete mode 100644 Perl/demos/Tk/demos/zinc_data/background_texture.gif delete mode 100644 Perl/demos/Tk/demos/zinc_data/hegias_parouest_TE.vid delete mode 100644 Perl/demos/Tk/demos/zinc_data/paper-grey.gif delete mode 100644 Perl/demos/Tk/demos/zinc_data/paper-grey1.gif delete mode 100644 Perl/demos/Tk/demos/zinc_data/paper.gif delete mode 100644 Perl/demos/Tk/demos/zinc_data/stripped_texture.gif delete mode 100644 Perl/demos/Tk/demos/zinc_data/videomap_orly delete mode 100644 Perl/demos/Tk/demos/zinc_data/videomap_paris-w_90_2 delete mode 100644 Perl/demos/Tk/demos/zinc_data/zinc.gif delete mode 100644 Perl/demos/Tk/demos/zinc_data/zinc_anti.gif delete mode 100644 Perl/demos/Tk/demos/zinc_lib/MagicLens.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/Zetris.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/all_options.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/atomic-groups.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/clipping.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/color-circular.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/color-path-and-conic.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/color-x.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/color-y.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/contours.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/counter.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/curve_bezier.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/fillrule.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/groups_in_ATC_strips.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/groups_priority.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/icon_zoom_resize.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/items.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/labelformat.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/lines.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/mapinfo.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/path_tags.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/rotation.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/simple_interaction_track.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/simpleradar.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/testGraphics.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/textInput.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/tiger.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/tkZincLogo.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/transforms.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/translation.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/triangles.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/wheelOfFortune.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/window-contours.pl delete mode 100644 Perl/demos/Tk/demos/zinc_lib/zoom.pl delete mode 100644 Perl/demos/Tk/demos/zinc_pm/SimpleRadarControls.pm delete mode 100644 Perl/demos/t/no-test.t delete mode 100644 Perl/demos/zinc-demos delete mode 100755 Perl/export2cpan delete mode 100644 Perl/t/.cvsignore delete mode 100644 Perl/t/AnimatedGradient.t delete mode 100644 Perl/t/Bbox.t delete mode 100644 Perl/t/Coords.t delete mode 100644 Perl/t/Images.t delete mode 100644 Perl/t/Import.t delete mode 100644 Perl/t/PreviousKnownBugs.t delete mode 100644 Perl/t/Test/Builder.pm delete mode 100644 Perl/t/Test/Harness.pm delete mode 100644 Perl/t/Test/Harness/Assert.pm delete mode 100644 Perl/t/Test/Harness/Iterator.pm delete mode 100644 Perl/t/Test/Harness/Straps.pm delete mode 100644 Perl/t/Test/More.pm delete mode 100644 Perl/t/TestLog.pm delete mode 100644 Perl/t/Text.t delete mode 100644 Perl/t/Transformations.t delete mode 100644 Perl/t/find.t delete mode 100644 Perl/t/test-methods.pl delete mode 100644 Perl/t/test-no-crash.pl delete mode 100644 Perl/t/testdoc.pl delete mode 100644 Perl/t/text.t delete mode 100644 Perl/t/traceutils.t delete mode 100644 Python/library/Zinc.py.in delete mode 100644 README delete mode 100644 aclocal.m4 delete mode 100644 bootstrap delete mode 100644 buildperl.tcl delete mode 100755 configure delete mode 100644 configure.in delete mode 100644 debian/.cvsignore delete mode 100644 debian/README.debian delete mode 100644 debian/changelog delete mode 100644 debian/control delete mode 100644 debian/copyright delete mode 100755 debian/rules delete mode 100644 debian/zinc-python.postinst delete mode 100644 debian/zinc-python.prerm delete mode 100644 demos/allOptions.tcl delete mode 100644 demos/atomicGroups.tcl delete mode 100644 demos/clipping.tcl delete mode 100644 demos/colorCircular.tcl delete mode 100644 demos/colorX.tcl delete mode 100644 demos/colorY.tcl delete mode 100644 demos/contours.tcl delete mode 100644 demos/curveBezier.tcl delete mode 100644 demos/data/hegias_parouest_TE.vid delete mode 100644 demos/data/videomap_orly delete mode 100644 demos/data/videomap_paris-w_90_2 delete mode 100644 demos/fillRule.tcl delete mode 100644 demos/groupsInAtcStrips.tcl delete mode 100644 demos/groupsPriority.tcl delete mode 100644 demos/iconTransform.tcl delete mode 100644 demos/images/background_texture.gif delete mode 100644 demos/images/paper-grey.gif delete mode 100644 demos/images/paper-grey1.gif delete mode 100644 demos/images/paper.gif delete mode 100644 demos/images/photoAlpha.png delete mode 100644 demos/images/stripped_texture.gif delete mode 100644 demos/images/zinc.gif delete mode 100644 demos/items.tcl delete mode 100644 demos/labelformat.tcl delete mode 100644 demos/lines.tcl delete mode 100644 demos/magicLens.tcl delete mode 100644 demos/pathTags.tcl delete mode 100644 demos/photoAlpha.tcl delete mode 100644 demos/reliefs.tcl delete mode 100644 demos/simpleInteractionTrack.tcl delete mode 100644 demos/simpleRadar.tcl delete mode 100644 demos/testGraphics.tcl delete mode 100644 demos/textInput.tcl delete mode 100644 demos/tiger.tcl delete mode 100644 demos/tkZincLogo.tcl delete mode 100644 demos/transforms.tcl delete mode 100644 demos/triangles.tcl delete mode 100644 demos/windowContours.tcl delete mode 100644 demos/zinc-widget delete mode 100644 doc/.cvsignore delete mode 100644 doc/alledges.png delete mode 100644 doc/allgradients.png delete mode 100644 doc/alllineshapes.png delete mode 100644 doc/allreliefs.png delete mode 100644 doc/alphastip.png delete mode 100644 doc/atcsymb.png delete mode 100644 doc/fillrule.png delete mode 100644 doc/refman.tex delete mode 100644 doc/tabularexample.png delete mode 100644 doc/textthroughholes.png delete mode 100644 doc/tkzinclogo.png delete mode 100644 doc/trackexample.png delete mode 100644 doc/waypointexample.png delete mode 100644 library/pkgIndex.tcl delete mode 100644 library/zincGraphics.tcl delete mode 100644 library/zincLogo.tcl delete mode 100644 library/zincText.tcl delete mode 100644 libtess/GL/gl.h delete mode 100644 libtess/GL/glext.h delete mode 100644 libtess/Imakefile delete mode 100644 libtess/README delete mode 100644 libtess/alg-outline delete mode 100644 libtess/dict-list.h delete mode 100644 libtess/dict.c delete mode 100644 libtess/dict.h delete mode 100644 libtess/geom.c delete mode 100644 libtess/geom.h delete mode 100644 libtess/glu.h delete mode 100644 libtess/gluos.h delete mode 100644 libtess/libtess_la_SOURCES delete mode 100644 libtess/memalloc.c delete mode 100644 libtess/memalloc.h delete mode 100644 libtess/mesh.c delete mode 100644 libtess/mesh.h delete mode 100644 libtess/normal.c delete mode 100644 libtess/normal.h delete mode 100644 libtess/priorityq-heap.c delete mode 100644 libtess/priorityq-heap.h delete mode 100644 libtess/priorityq-sort.h delete mode 100644 libtess/priorityq.c delete mode 100644 libtess/priorityq.h delete mode 100644 libtess/render.c delete mode 100644 libtess/render.h delete mode 100644 libtess/sweep.c delete mode 100644 libtess/sweep.h delete mode 100644 libtess/tess.c delete mode 100644 libtess/tess.h delete mode 100644 libtess/tessmono.c delete mode 100644 libtess/tessmono.h delete mode 100644 redhat/changelog delete mode 100644 redhat/perl-Tk-Zinc.spec delete mode 100644 redhat/rules delete mode 100644 sandbox/Controls.pm delete mode 100644 sandbox/alledges.pl delete mode 100644 sandbox/allgradients.pl delete mode 100644 sandbox/allgradients.tcl delete mode 100644 sandbox/alllineshapes.pl delete mode 100644 sandbox/allreliefs.pl delete mode 100644 sandbox/allreliefs.tcl delete mode 100644 sandbox/bouton-down.xpm delete mode 100644 sandbox/bouton.xpm delete mode 100644 sandbox/conical.tcl delete mode 100644 sandbox/contours.tcl delete mode 100644 sandbox/controls.tcl delete mode 100644 sandbox/defs.tcl delete mode 100644 sandbox/fvwm.xbm delete mode 100644 sandbox/lines.pl delete mode 100644 sandbox/logo.gif delete mode 100644 sandbox/smooth.tcl delete mode 100644 sandbox/testarc.tcl delete mode 100644 sandbox/testbezier.pl delete mode 100644 sandbox/testbezier.tcl delete mode 100644 sandbox/testbitmaps.tcl delete mode 100644 sandbox/testicon.tcl delete mode 100644 sandbox/testplug.pl delete mode 100644 sandbox/testpoly.tcl delete mode 100644 sandbox/testrect.pl delete mode 100644 sandbox/testrelief.pl delete mode 100644 sandbox/testrelief.tcl delete mode 100644 sandbox/testshape.pl delete mode 100644 sandbox/testshape.tcl delete mode 100644 sandbox/testtext.tcl delete mode 100644 sandbox/testwind.tcl delete mode 100644 sandbox/testzinc.pl delete mode 100644 sandbox/textexpand.tcl delete mode 100644 sandbox/texture-bois1.xpm delete mode 100644 sandbox/texture-paper.xpm delete mode 100644 sandbox/trash.xbm delete mode 100644 sandbox/triangles.pl delete mode 100644 sandbox/xpenguin.png delete mode 100644 sandbox/zinc.tcl delete mode 100644 sandbox/zinc.test delete mode 100644 starkit.tcl.in delete mode 100644 starkit/demo.tcl delete mode 100644 starkit/main.tcl delete mode 100644 tclconfig/README.txt delete mode 100644 tclconfig/install-sh delete mode 100644 tclconfig/tcl.m4 delete mode 100644 tests/all.tcl delete mode 100644 tests/rectangle.test delete mode 100644 tkzinc.m4 delete mode 100644 win/Tkzinc.aip.in delete mode 100644 win/Tkzincperl.aip.in delete mode 100644 win/WinPort.c delete mode 100644 win/makefile.vc.in delete mode 100644 win/package.tcl diff --git a/.cvsignore b/.cvsignore deleted file mode 100644 index a489df5..0000000 --- a/.cvsignore +++ /dev/null @@ -1,17 +0,0 @@ -Makefile -depends -config.h -config.cache -config.log -config.status -build -tk -bugs -om -ptk -*.prj -*.pws -*.cache -export2cpan -build-stamp -pkgIndex.tcl diff --git a/BUGS b/BUGS deleted file mode 100644 index 521e0e6..0000000 --- a/BUGS +++ /dev/null @@ -1,16 +0,0 @@ -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. diff --git a/Copyright b/Copyright deleted file mode 100644 index df4bdb2..0000000 --- a/Copyright +++ /dev/null @@ -1,17 +0,0 @@ - Copyright (c) 1993 - 2003 CENA, Patrick Lecoanet -- - - This code is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - 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. - - You should have received a copy of the GNU Library General Public - License along with this code; if not, write to the Free - Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, - MA 02111-1307, USA. - diff --git a/Makefile.in b/Makefile.in deleted file mode 100644 index 761fcf7..0000000 --- a/Makefile.in +++ /dev/null @@ -1,520 +0,0 @@ -# Copyright (c) 1993 - 2003 CENA, Patrick Lecoanet -- -# -# This code is free software; you can redistribute it and/or -# modify it under the terms of the GNU Library General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# 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. -# -# You should have received a copy of the GNU Library General Public -# License along with this code; if not, write to the Free -# Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -# -# $Revision$ -# -# -# This Makefile.in is derived from the Sample TEA template which is: -# -# Copyright (c) 1999 Scriptics Corporation. -# Copyright (c) 2002 ActiveState SRL. -# - -#======================================================================== -# Enumerate the names of the source files included in this package. -# EXTRA_SOURCES will be replaced by WIN_SOURCES or UNIX_SOURCES, as is -# appropriate for your platform. It is not important to specify the -# directory, as long as it is the $(srcdir) or in the generic, win or -# unix subdirectory. -#======================================================================== - -Atc_SOURCES = @Atc_SOURCES@ -Tkzinc_SOURCES = 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 Window.c \ - tkZinc.c @EXTRA_SOURCES@ $(Atc_SOURCES) -Tess_SOURCES = dict.c geom.c memalloc.c mesh.c normal.c priorityq.c \ - render.c sweep.c tess.c tessmono.c - -WIN_SOURCES = WinPort.c -UNIX_SOURCES = - -#======================================================================== -# Identify the object files. This replaces .c with .$(OBJEXT) for all -# the named source files. These objects are created and linked into the -# final library. -# Normally we would use $(OBJEXT), but certain make executables won't do -# the extra macro in a macro conversion properly. -# -# "Tkzinc_LIB_FILE" refers to the library (dynamic or static as per -# configuration options) composed of the named objects. -#======================================================================== - -Tkzinc_OBJECTS = $(Tkzinc_SOURCES:.c=.@OBJEXT@) -Tess_OBJECTS = $(Tess_SOURCES:.c=.@OBJEXT@) -Tkzinc_LIB_FILE = @Tkzinc_LIB_FILE@ -Tess_LIB_FILE = @Tess_LIB_FILE@ - -#======================================================================== -# RUNTIME_SOURCES identifies Tcl runtime files that are associated with -# this package that need to be installed, if any. -#======================================================================== - -RUNTIME_SOURCES = zincLogo.tcl zincText.tcl zincGraphics.tcl - -#======================================================================== -# This is a list of header files to be installed -#======================================================================== - -GENERIC_HDRS = - -#======================================================================== -# Nothing of the variables below this line need to be changed. -#======================================================================== - -lib_BINARIES = $($(PACKAGE)_LIB_FILE) -aux_BINARIES = @aux_BINARIES@ -bin_BINARIES = @bin_BINARIES@ -BINARIES = $(Tess_LIB_FILE) $(lib_BINARIES) - -SHELL = @SHELL@ - -srcdir = @srcdir@ -prefix = @prefix@ -exec_prefix = @exec_prefix@ - -bindir = @bindir@ -libdir = @libdir@ -datadir = @datadir@ -mandir = @mandir@ -includedir = @includedir@ - -DESTDIR = - -PKG_DIR = $(PACKAGE)$(VERSION) -pkgdatadir = $(datadir)/$(PKG_DIR) -pkglibdir = $(libdir)/$(PKG_DIR) -pkgincludedir = $(includedir)/$(PKG_DIR) - -top_builddir = . - -tess_dir = $(srcdir)/libtess -generic_dir = $(srcdir)/generic -unix_dir = $(srcdir)/unix -windows_dir = $(srcdir)/win - -INSTALL = @INSTALL@ -INSTALL_PROGRAM = @INSTALL_PROGRAM@ -INSTALL_DATA = @INSTALL_DATA@ -INSTALL_SCRIPT = @INSTALL_SCRIPT@ - -PACKAGE = @PACKAGE@ -VERSION = @VERSION@ -CC = @CC@ -CFLAGS_DEBUG = @CFLAGS_DEBUG@ -CFLAGS_DEFAULT = @CFLAGS_DEFAULT@ -CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ -CFLAGS_WARNING = @CFLAGS_WARNING@ -CLEANFILES = @CLEANFILES@ -EXEEXT = @EXEEXT@ -LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ -LDFLAGS_DEFAULT = @LDFLAGS_DEFAULT@ -LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ -MAKE_LIB = @MAKE_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_LDFLAGS = @SHLIB_LDFLAGS@ -SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ -STLIB_LD = @STLIB_LD@ -TCL_DEFS = @TCL_DEFS@ -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 -INCLUDES = -I$(srcdir)/generic \ - @TCL_INCLUDES@ @TK_INCLUDES@ @TK_XINCLUDES@ @GL_INCLUDES@ -I$(tess_dir) - -EXTRA_CFLAGS = $(MEM_DEBUG_FLAGS) @EXTRA_CFLAGS@ - -DEFS = $(TCL_DEFS) @DEFS@ $(EXTRA_CFLAGS) - -CONFIG_CLEAN_FILES = Makefile - -CPPFLAGS = @CPPFLAGS@ -LIBS = @LIBS@ -AR = ar -CFLAGS = @CFLAGS@ -COMPILE = $(CC) $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) - -#======================================================================== -# Start of user-definable TARGETS section -#======================================================================== - -#======================================================================== -# TEA TARGETS. Please note that the "libraries:" target refers to platform -# independent files, and the "binaries:" target inclues executable programs and -# platform-dependent libraries. Modify these targets so that they install -# the various pieces of your package. The make and install rules -# for the BINARIES that you specified above have already been done. -#======================================================================== - -all: binaries libraries doc - -#======================================================================== -# The binaries target builds executable programs, Windows .dll's, unix -# shared/static libraries, and any other platform-dependent files. -# The list of targets to build for "binaries:" is specified at the top -# of the Makefile, in the "BINARIES" variable. -#======================================================================== - -binaries: $(BINARIES) pkgIndex.tcl - -libraries: - -#======================================================================== -# 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, LaTeX2html) 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: - -pdf: doc/refman.tex - (cd doc; \ - rm -f refman.aux refman.ilg refman.ind refman.out refman.tpt; \ - rm -f refman.idx refman.lof refman.log refman.lot refman.toc; \ - pdflatex refman.tex; \ - pdflatex refman.tex; \ - makeindex refman.idx; \ - pdflatex refman.tex; \ - thumbpdf refman.pdf; \ - pdflatex refman.tex;) - -html: doc/refman.tex - (cd doc; \ - rm -f refman.ilg refman.ind refman.out; \ - rm -f refman.idx refman.lof refman.log refman.lot refman.toc; \ - mkdir -p refman; cp -f *.png refman; \ - latex2html -split 4 -show_section_numbers -local_icons refman.tex) - -install: all install-binaries install-libraries install-demos install-doc - -install-binaries: binaries install-lib-binaries install-bin-binaries - - -#======================================================================== -# This rule installs platform-independent files, such as header files. -#======================================================================== - -install-libraries: libraries - @if test "x$(GENERIC_HDRS)" != "x"; then \ - mkdir -p $(DESTDIR)$(includedir); \ - echo "Installing header files in $(DESTDIR)$(includedir)"; \ - for i in "$(GENERIC_HDRS)" ; do \ - echo "Installing $$i" ; \ - $(INSTALL_DATA) $$i $(DESTDIR)$(includedir) ; \ - done; \ - fi - -#======================================================================== -# This rule installs the demos files and associated images. -#======================================================================== - -install-demos: - @mkdir -p $(DESTDIR)$(pkglibdir)/demos - @echo "Installing demo files in $(DESTDIR)$(pkglibdir)/demos" - @for p in $(srcdir)/demos/*; do \ - if test -f $$p; then \ - p=`basename $$p`; \ - echo " Install $$p $(DESTDIR)$(pkglibdir)/demos/$$p"; \ - $(INSTALL_DATA) $(srcdir)/demos/$$p $(DESTDIR)$(pkglibdir)/demos/$$p; \ - fi; \ - done - @mkdir -p $(DESTDIR)$(pkglibdir)/demos/images - @mkdir -p $(DESTDIR)$(pkglibdir)/demos/data - @for p in $(srcdir)/demos/images/*; do \ - if test -f $$p; then \ - p=`basename $$p`; \ - echo " Install $$p $(DESTDIR)$(pkglibdir)/demos/images/$$p"; \ - $(INSTALL_DATA) $(srcdir)/demos/images/$$p $(DESTDIR)$(pkglibdir)/demos/images/$$p; \ - fi; \ - done - @for p in $(srcdir)/demos/data/*; do \ - if test -f $$p; then \ - p=`basename $$p`; \ - echo " Install $$p $(DESTDIR)$(pkglibdir)/demos/data/$$p"; \ - $(INSTALL_DATA) $(srcdir)/demos/data/$$p $(DESTDIR)$(pkglibdir)/demos/data/$$p; \ - fi; \ - done - -#======================================================================== -# Install documentation. Unix manpages should go in the $(mandir) -# directory. -#======================================================================== - -install-doc: doc - @mkdir -p $(DESTDIR)$(mandir)/mann - @echo "Installing documentation in $(DESTDIR)$(mandir)" - @for i in $(srcdir)/doc/*.n; do \ - if test -f $$i; then \ - i=`basename $$i`; \ - echo "Installing $$i"; \ - rm -f $(DESTDIR)$(mandir)/mann/$$i; \ - $(INSTALL_DATA) $(srcdir)/doc/$$i $(DESTDIR)$(mandir)/mann/$$i ; \ - fi \ - done - -test: binaries libraries - $(TCLSH) `@CYGPATH@ $(srcdir)/tests/all.tcl` $(TESTFLAGS) ; \ - -shell: binaries libraries - @$(TCLSH) $(SCRIPT) - -gdb: - $(TCLSH_ENV) gdb $(TCLSH_PROG) $(SCRIPT) - -depend: - - -#======================================================================== -# $($(PACKAGE)_LIB_FILE) should be listed as part of the BINARIES variable -# mentioned above. That will ensure that this target is built when you -# run "make binaries". -# -# The $($(PACKAGE)_OBJECTS) objects are created and linked into the final -# library. In most cases these object files will correspond to the -# source files above. -#======================================================================== - -$($(PACKAGE)_LIB_FILE): $($(PACKAGE)_OBJECTS) - -rm -f $($(PACKAGE)_LIB_FILE) - ${MAKE_LIB} - #$(RANLIB) $($(PACKAGE)_LIB_FILE) - -$(Tess_LIB_FILE): $(Tess_OBJECTS) - -rm -f $(Tess_LIB_FILE) - ${STLIB_LD} $@ $(Tess_OBJECTS) - $(RANLIB) $(Tess_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)/libtess:$(srcdir)/generic:$(srcdir)/unix:$(srcdir)/win - -.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 require Tk \; pkg_mkIndex -verbose -load Tk . $($(PACKAGE)_LIB_FILE) \; exit ) | $(TCLSH) - -pkgIndex.tcl-hand: - (echo 'package ifneeded $(PACKAGE) $(VERSION) \ - [list load [file join $$dir $($(PACKAGE)_LIB_FILE)]]'\ - ) > pkgIndex.tcl - -#======================================================================== -# Distribution creation -# You may need to tweak this target to make it work correctly. -#======================================================================== - -COMPRESS = tar zcvf $(PKG_DIR).tar.gz $(PKG_DIR) -DIST_ROOT = /tmp/dist -DIST_DIR = $(DIST_ROOT)/$(PKG_DIR) - -dist-clean: - rm -rf $(DIST_DIR) $(DIST_ROOT)/$(PKG_DIR).tar.* - -dist: dist-clean - mkdir -p $(DIST_DIR) - cp -p $(srcdir)/BUGS $(srcdir)/README* $(srcdir)/Copyright* \ - $(srcdir)/aclocal.m4 $(srcdir)/configure $(srcdir)/*.in \ - $(DIST_DIR)/ - chmod 664 $(DIST_DIR)/Makefile.in $(DIST_DIR)/aclocal.m4 - chmod 775 $(DIST_DIR)/configure $(DIST_DIR)/configure.in - - -cp -p $(srcdir)/*.[ch] $(DIST_DIR)/ - - mkdir $(DIST_DIR)/tclconfig - cp $(srcdir)/tclconfig/install-sh $(srcdir)/tclconfig/tcl.m4 \ - $(DIST_DIR)/tclconfig/ - chmod 664 $(DIST_DIR)/tclconfig/tcl.m4 - chmod +x $(DIST_DIR)/tclconfig/install-sh - - -list='demos doc generic libtess debian redhat library mac tests unix win Perl Python'; \ - for p in $$list; do \ - if test -d $(srcdir)/$$p ; then \ - tar cf - --exclude=CVS --exclude=.cvsignore $$p | \ - (cd $(DIST_DIR); tar xf -) \ - fi; \ - done - - (cd $(DIST_ROOT); $(COMPRESS);) - -#======================================================================== -# End of user-definable section -#======================================================================== - -#======================================================================== -# Don't modify the file to clean here. Instead, set the "CLEANFILES" -# variable in configure.in -#======================================================================== - -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. -#======================================================================== - -install-lib-binaries: - @mkdir -p $(DESTDIR)$(pkglibdir) - @list='$(lib_BINARIES)'; for p in $$list; do \ - if test -f $$p; then \ - echo " $(INSTALL_PROGRAM) $$p $(DESTDIR)$(pkglibdir)/$$p"; \ - $(INSTALL_PROGRAM) $$p $(DESTDIR)$(pkglibdir)/$$p; \ - echo " $(RANLIB) $(DESTDIR)$(pkglibdir)/$$p"; \ - $(RANLIB) $(DESTDIR)$(pkglibdir)/$$p; \ - ext=`echo $$p|sed -e "s/.*\.//"`; \ - if test "x$$ext" = "xdll"; then \ - lib=`basename $$p|sed -e 's/.[^.]*$$//'`.lib; \ - if test -f $$lib; then \ - echo " $(INSTALL_DATA) $$lib $(DESTDIR)$(pkglibdir)/$$lib"; \ - $(INSTALL_DATA) $$lib $(DESTDIR)$(pkglibdir)/$$lib; \ - fi; \ - fi; \ - fi; \ - done - @list='$(aux_BINARIES)'; for p in $$list; do \ - if test -f $$p; then \ - echo " Install $$p $(DESTDIR)$(libdir)/$$p"; \ - $(INSTALL_PROGRAM) $$p $(DESTDIR)$(libdir)/$$p; \ - fi; \ - done - @list='$(RUNTIME_SOURCES)'; for p in $$list; do \ - if test -f $(srcdir)/library/$$p; then \ - echo " Install $$p $(DESTDIR)$(pkglibdir)/$$p"; \ - $(INSTALL_DATA) $(srcdir)/library/$$p $(DESTDIR)$(pkglibdir)/$$p; \ - fi; \ - done -# -# Construct a full pkgIndex in the installation directory - (cd $(DESTDIR)$(pkglibdir); \ - (echo package require Tk \; pkg_mkIndex -load Tk . \ - $(RUNTIME_SOURCES) $($(PACKAGE)_LIB_FILE) \; exit;) | $(TCLSH)) - -#======================================================================== -# Install binary executables (e.g. .exe files and dependent .dll files) -# This is for files that must go in the bin directory (located next to -# wish and tclsh), like dependent .dll files on Windows. -# -# You should not have to modify this target, except to define bin_BINARIES -# above if necessary. -#======================================================================== - -install-bin-binaries: - @mkdir -p $(DESTDIR)$(bindir) - @list='$(bin_BINARIES)'; for p in $$list; do \ - if test -f $$p; then \ - echo " $(INSTALL_PROGRAM) $$p $(DESTDIR)$(bindir)/$$p"; \ - $(INSTALL_PROGRAM) $$p $(DESTDIR)$(bindir)/$$p; \ - fi; \ - done - -.SUFFIXES: .c .$(OBJEXT) - -Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status - cd $(top_builddir) \ - && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status - -uninstall-binaries: - list='$(lib_BINARIES)'; for p in $$list; do \ - rm -f $(DESTDIR)$(pkglibdir)/$$p; \ - done - list='$(RUNTIME_SOURCES)'; for p in $$list; do \ - rm -f $(DESTDIR)$(pkglibdir)/$$p; \ - done - list='$(bin_BINARIES)'; for p in $$list; do \ - rm -f $(DESTDIR)$(bindir)/$$p; \ - done - -.PHONY: all binaries 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: diff --git a/Perl/.cvsignore b/Perl/.cvsignore deleted file mode 100644 index 16b7eff..0000000 --- a/Perl/.cvsignore +++ /dev/null @@ -1,5 +0,0 @@ -Makefile -Zinc.bs -Zinc.c -pm_to_blib -blib diff --git a/Perl/Makefile.PL.in b/Perl/Makefile.PL.in deleted file mode 100644 index 611dddb..0000000 --- a/Perl/Makefile.PL.in +++ /dev/null @@ -1,140 +0,0 @@ -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 = '@MAJOR_VERSION@.@MINOR_VERSION@@PATCHLEVEL@'; - - -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', 'Window.c', 'tkZinc.c'); - -my @LIBTESS_C = ('dict.c', 'geom.c', 'memalloc.c', 'mesh.c', 'normal.c', 'priorityq.c', - 'render.c', 'sweep.c', 'tess.c', 'tessmono.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, @LIBTESS_C, @GENERIC_C ; - -my $NeededLibs = ['-L/usr/X11R6/lib -lXext -lX11 -lGL -L.']; - -if ($WIN) { - push @C, @WIN_C; - $NeededLibs = ['-lopengl32'] -} -my $ZincObj = "Zinc" . $Config{"_o"}; - -my $INC = "-I. -I$TkLibDir -I$TkLibDir/pTk -I$TkLibDir/X11"; - -unless ($WIN) { - $INC .= " -I/usr/X11R6/include"; -} - -# See lib/ExtUtils/MakeMaker.pm for details of how to influence -# the contents of the Makefile that is written. -WriteMakefile( - 'ABSTRACT' => 'a canvas offering groups, tranformations, transparency, color gradient...', - 'AUTHOR' => 'Patrick Lecoanet ', - 'NAME' => 'Tk::Zinc', - 'VERSION' => $VERSION, - 'PREREQ_PM' => $WIN ? {Tk => 8.004} : {Tk => 8.0}, - 'LIBS' => $NeededLibs, - '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", - ); - -sub get_flags { - my %DEF_FLAGS = ('GL' => 1, - 'SHAPE' => 1, - 'GL_DAMAGE' => 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; - $DEF_FLAGS{'GL_DAMAGE'} = 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'; - - 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 diff --git a/Perl/README b/Perl/README deleted file mode 100644 index e090549..0000000 --- a/Perl/README +++ /dev/null @@ -1,81 +0,0 @@ -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/ - - -* On a Linux system, you need Perl (>= 5.6) and perl-tk (800 or 804) 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: - - perl and perl-tk 804, - - Visual C++ or the Free Visual C++ Command Line Tools - - - -Install: - - perl Makefile.PL - # you can use the following options: --with-gl=yes|no --with-om=yes|no --with-shape=yes|no - # current defaults are --with-gl=yes --with-om=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. - - -up-to-date documentation is also available at http://www.tkzinc.org/index.php/Main/Documentation -You will find there the reference manual, a FAQ, a mailing list, its archive -etc... -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 (Python binding -are now obsoletes). - - -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 LGPL licence. -For the copyright, please, read the COPYRIGHT file. - -For any question on Tk::Zinc usage, build or installation pb, -please send email to zinc@tls.cena.fr -This mailing list can be subscribed from -http://www.tkzinc.org/index.php/Main/MailingList. You can -also send a question without subscribing, but you will be asked -for a confirmation to avoid spam on the list! - - -Authors and Contributors: - -Tk::Zinc main author is Patrick Lecoanet -Sub-Modules, demos and documentation have been developped by -Daniel Etienne, Christophe Mertz, Jean-Luc Vinot, with contributions -from Stéphane Chatty, Céline Schlienger, Alexandre Lemort -Stéphane Conversy contributed to the MacOSX port. -Many others contributed with their bug reports! diff --git a/Perl/Zinc.pm.in b/Perl/Zinc.pm.in deleted file mode 100644 index 0863458..0000000 --- a/Perl/Zinc.pm.in +++ /dev/null @@ -1,157 +0,0 @@ -# $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 = '@MAJOR_VERSION@.@MINOR_VERSION@@PATCHLEVEL@'; - - -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", "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>-EB(?I?); - -=head1 DESCRIPTION - -I 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 and html pages B. - -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 or as Debian or RedHat/Mandrake -packages at http://www.tkzinc.org/ or http://freshmeat.net/projects/zincisnotcanvas/ - -TkZinc is also available on CPAN since v3.294 (a kind of 3.2.94) - -=head1 AUTHOR - -Patrick Lecoanet - -=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, L. - -=cut diff --git a/Perl/Zinc.xs b/Perl/Zinc.xs deleted file mode 100644 index 26cd0c7..0000000 --- a/Perl/Zinc.xs +++ /dev/null @@ -1,59 +0,0 @@ -/* - 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 -#include -#include - -#include - -#include -#include -#ifdef _WIN32 -#include -#endif -#include -#include -#include -#include - -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); - } diff --git a/Perl/Zinc/Debug.pm b/Perl/Zinc/Debug.pm deleted file mode 100644 index 6d4758c..0000000 --- a/Perl/Zinc/Debug.pm +++ /dev/null @@ -1,3023 +0,0 @@ -# Tk::Zinc::Debug Perl Module : -# -# For debugging/analysing a Zinc application. -# -# Author : Daniel Etienne -# -# $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("", - [\&startrectangle, 'simple', 'Enclosed', - 'sienna']); - $selectedzinc->Tk::bind("", \&resizerectangle); - $selectedzinc->Tk::bind("", - [\&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("", [\&startrectangle, 'mixed', - 'Overlap', 'sienna']); - $selectedzinc->Tk::bind("", \&resizerectangle); - $selectedzinc->Tk::bind("", - [\&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("", [\&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("", [\&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('', sub { - my $ev = $selectedzinc->XEvent; - ($x0, $y0) = ($ev->x, $ev->y); - }); - $selectedzinc->Tk::bind('', 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("", 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("", 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('', 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('', [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('', sub { &hidecontour($zinc); }); - $lab->bind('', sub { &hidecontour($zinc); }); - $lab->bind('', 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('', sub { &hidecontour($zinc); }); - $lab1->bind('', sub { &hidecontour($zinc); }); - $lab1->bind('', 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('', [\&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('', [\&showcontourpt, $zinc, $color, - $item, $index+1, $deviceflag, $labels, @contour]); - $widget->bind('', [\&showcontourpt, $zinc, $color, - $item, $index+1, $deviceflag, $labels, @contour]); - $widget->bind('', [\&showcontourpt, $zinc, $color, - $item, $index-1, $deviceflag, $labels, @contour]); - $widget->bind('', [\&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('', [\&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('', [\&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', "", "keyword"); - $text->insert('end', " arrow key moves the anchor point to the item right on ". - "top of the current anchor item. "); - $text->insert('end', "", "keyword"); - $text->insert('end', " arrow key moves the anchor point to the item right below ". - "the current anchor item. "); - $text->insert('end', "", "keyword"); - $text->insert('end', " arrow key moves the anchor to the parent item of the ". - "current anchor item. "); - $text->insert('end', "", "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', "", "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 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 => <{zn} = $zinc->toplevel->Bitmap(-data => <{findenclosed} = $zinc->toplevel->Bitmap(-data => <{findoverlap} = $zinc->toplevel->Bitmap(-data => <{tree} = $zinc->toplevel->Bitmap(-data => <{item} = $zinc->toplevel->Bitmap(-data => <{id} = $zinc->toplevel->Bitmap(-data => <{snapshot} = $zinc->toplevel->Bitmap(-data => <{zoomminus} = $zinc->toplevel->Bitmap(-data => <{zoomplus} = $zinc->toplevel->Bitmap(-data => <{move} = $zinc->toplevel->Bitmap(-data => <{balloon} = $zinc->toplevel->Bitmap(-data => <{cursorxy} = $zinc->toplevel->Bitmap(-data => <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('', 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('', - 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; - my $width = length($def); - $e->configure(-width => $width); - $e->insert($i0, $def); - $e->bind('', 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('', - 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('', \&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('', sub {$w->yview('scroll', -1, 'page')}); - $w->bind('', sub {$w->yview('scroll', -1, 'unit')}); - $w->bind('', sub {$w->yview('scroll', -$count, 'unit')}); - - $w->bind('', sub {$w->yview('scroll', 1, 'page')}); - $w->bind('', sub {$w->yview('scroll', 1, 'unit')}); - $w->bind('', 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 key in the toplevel of your application to display the Tk::Zinc::Debug buttons bar. - - -Features : - -=over - -=item B 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 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 snapshot the application window - -In order to illustrate a graphical bug for example. - -=item B display coordinates of the X cursor. - -=item B 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. In this case, the B 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($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 /basename.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 - - -=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. diff --git a/Perl/Zinc/Graphics.pm b/Perl/Zinc/Graphics.pm deleted file mode 100644 index 8305c81..0000000 --- a/Perl/Zinc/Graphics.pm +++ /dev/null @@ -1,3067 +0,0 @@ -#----------------------------------------------------------------------------------- -# -# 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 -# -# $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 : identifiant du widget Zinc -# parentgroup : identifiant du group parent -# -# options : -# -itemtype : type de l'item à construire (type zinc ou metatype) -# -coords : coordonnées de l'item -# -metacoords : calcul de coordonnées par type d'item différent de -itemtype -# -contours : paramètres multi-contours -# -params : arguments spécifiques de l'item à passer au widget -# -addtags : [list of specific tags] to add to params -tags -# -texture : ajout d'une texture à l'item -# -pattern : ajout d'un pattern à l'item -# -relief : création d'un relief à l'item invoque la fonction &graphicItemRelief() -# -shadow : création d'une ombre portée à l'item invoque la fonction &graphicItemShadow() -# -scale : application d'une transformation zinc->scale à l'item -# -translate : <[dx,dy]> application d'un transformation zinc->translate à l'item. -# -rotate : application d'une transformation zinc->rotate (en degré) à l'item -# -name : nom de l'item -# spécifiques item group : -# -clip : paramètres de clipping d'un item group (coords ou item) -# -items : 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 : identifiant du widget zinc -# item : identifiant de l'item source -# options : -# -num : nombre d'item total (par defaut 2) -# -dxy : <[dx, dy]> translation entre 2 duplications (par defaut [0,0]) -# -angle : rotation entre 2 duplications -# -copytag : ajout d'un tag indexé pour chaque copie -# -params : {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 : type de primitive utilisée -# -coords : 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 : identifiant du widget zinc -# item : identifiant de l'item source -# options : -# -linear : réduction à des segments non curviligne (par défaut 0) -# -realcoords : coordonnées à transformer dans le groupe père (par défaut 0) -# -adjust : 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 : coordonnées bbox (haut-gauche et bas-droite) du rectangle -# options : -# -radius : rayon de raccord d'angle -# -corners : 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 : coordonnées bbox du rectangle exinscrit -# options : -# -corners : 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 : 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 : point centre du polygone -# options : -# -numsides : nombre de cotés -# -radius : rayon de définition du polygone (distance centre-sommets) -# -inner_radius : rayon interne (polygone type étoile) -# -corners : liste des raccords de sommets [0|1] par défaut [1,1,1,1] -# -corner_radius : rayon de raccord des cotés -# -startangle : 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 : identifiant de l'item group parent -# coords : les 3 points de l'angle -# radius : 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 : les 3 points de l'angle -# radius : 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 : liste de coordonnées des points de la curve -# options : -# -radius : rayon de raccord d'angle -# -corners : 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 : liste de coordonnées des sommets de la polyline -# options : -# -radius : rayon global de raccord d'angle -# -corners : liste des raccords de sommets [0|1] par défaut [1,1,1,1], -# -corners_radius : 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 : liste de coordonnées des points du path -# options : -# -closed : ligne fermée -# -shifting : sens de décalage du path (par défaut center) -# -linewidth : 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 : liste de coordonnées des points de la ligne -# options : -# -closed : ligne fermée -# -shifting : sens de décalage du contour (par défaut center) -# -linewidth : 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 : liste de coordonnées des points du path -# options : -# -closed : ligne fermée -# -shifting : <'out'|'in'> sens de décalage du path (par défaut out) -# -width : 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 : coordonnées du point de référence -# line : 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 : coordonnées du point de départ du segment -# endpoint : 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 : coordonnées du point de départ du segment -# endpoint : 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 : coordonnées du premier point de définition de l'angle -# pt1 : coordonnées du deuxième point de définition de l'angle -# pt2 : 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 : centre de l'arc, -# radius : rayon de l'arc, -# options : -# -angle : angle de départ en degré de l'arc (par défaut 0) -# -extent : delta angulaire en degré de l'arc (par défaut 360), -# -step : 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 [x,y] du centre de l'arc, -# radius : rayon de l'arc, -# 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 : identifiant du widget zinc -# item : identifiant de l'item source -# options : -# -tunits : nombre pas de division des segments bezier (par défaut 20) -# -adjust : 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 : liste des coordonnées curve à transformer -# options : -# -tunits : nombre pas de division des segments bezier (par défaut 20) -# -adjust : 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 : identifiant du widget zinc -# parentgroup : identifiant de l'item group parent -# -# options : -# -coords : coordonnées haut-gauche et bas-droite du rectangle -# englobant du TabBox -# -params : arguments spécifiques des items curve à passer au widget -# -texture : ajout d'une texture aux items curve -# -tabtitles : table de hash de définition des titres onglets -# -pageitems : table de hash de définition des pages internes -# -relief : table de hash de définition du relief de forme -# -# (options de construction géometrique passées à tabBoxCoords) -# -numpages : 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'>|| : largeur des onglets -# 'auto' largeur répartie, les largeurs sont auto-ajustée si besoin. -# -tabheight : <'auto'>| : hauteur des onglets -# -tabshift : <'auto'>| offset de 'biseau' entre base et haut de l'onglet (défaut auto) -# -radius : rayon des arrondis d'angle -# -overlap : <'auto'>| offset de recouvrement/séparation entre onglets -# -corners : 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 : coordonnées haut-gauche bas-droite du rectangle englobant -# de la tabbox -# options -# -numpages : 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'>|| : largeur des onglets -# 'auto' largeur répartie, les largeurs sont auto-ajustée si besoin. -# -tabheight : <'auto'>| : hauteur des onglets -# -tabshift : <'auto'>| offset de 'biseau' entre base et haut de l'onglet (défaut auto) -# -radius : rayon des arrondis d'angle -# -overlap : <'auto'>| offset de recouvrement/séparation entre onglets -# -corners : 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 : identifiant du widget zinc -# item : identifiant de l'item zinc -# options : table d'options -# -closed : 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 : couleur du relief (défaut couleur de la forme) -# -smoothed : facettes relief lissées ou non (défaut 1) -# -lightangle : angle d'éclairage (défaut valeur générale widget) -# -width : 'épaisseur' du relief en pixel -# -fine : 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 : identifiant widget Zinc -# item : identifiant item Zinc -# options : table d'options -# -closed : 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 : couleur du relief (défaut couleur de la forme) -# -smoothed : facettes relief lissées ou non (défaut 1) -# -lightangle : angle d'éclairage (défaut valeur générale widget) -# -width : 'é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 : identifiant widget Zinc -# item : identifiant item Zinc -# options : table d'options -# -opacity : opacité de l'ombre (défaut 50) -# -filled : remplissage totale de l'ombre (hors bordure) (defaut 1) -# -lightangle : angle d'éclairage (défaut valeur générale widget) -# -distance : distance de projection de l'ombre en pixel -# -enlarging : grossi de l'ombre portée en pixels (defaut 0) -# -width : taille de diffusion/diffraction (défaut 4) -# -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 : identifiant widget Zinc -# item : identifiant item Zinc -# options : table d'options -# -opacity : opacité de l'ombre (défaut 50) -# -lightangle : angle d'éclairage (défaut valeur générale widget) -# -distance : distance de projection de l'ombre en pixel (défaut 10) -# -enlarging : grossi de l'ombre portée en pixels (defaut 2) -# -width : taille de diffusion/diffraction (défaut distance -2) -# -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, , P2]> liste des points définissant le segment de bezier -# -# options : -# -tunits : nombre pas de division des segments bezier (par défaut 20) -# -skipend : : 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 = (représentation du temps : de 0 à 1) -# coords = (P1, 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 : 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 : liste des points définissant le segment de bezier -# -# options : -# -precision : seuil limite du calcul d'approche de la courbe -# -skipend : : 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 : 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 : identifiant du widget zinc -# filename : nom du fichier texture -# options -# -storage : 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 : identifiant du widget zinc -# filename : nom du fichier image -# options -# -storage : 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 : identifiant du widget zinc -# filenames : list des noms des fichier image -# options -# -storage : 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 : identifiant du widget zinc -# grads : 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 : 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 : couleur au format zinc -# newL : (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 : identifiant du widget zinc -# item : 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 : première couleur zinc -# color2 : seconde couleur zinc -# rate : (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 : 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 : (de 0 à 1) valeur de la composante rouge de la couleur RGB -# g : (de 0 à 1) valeur de la composante verte de la couleur RGB -# b : (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 : (de 0 à 1) valeur de la composante luminosité de la couleur CIE LCH -# C : (de 0 à 1) valeur de la composante saturation de la couleur CIE LCH -# H : (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 : (de 0 à 1) valeur de la composante rouge de la couleur RGB -# g : (de 0 à 1) valeur de la composante verte de la couleur RGB -# b : (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 : (de 0 à 1) valeur de la composante teinte de la couleur HLS -# L : (de 0 à 1) valeur de la composante luminosité de la couleur HLS -# S : (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__ - diff --git a/Perl/Zinc/Graphics.pod b/Perl/Zinc/Graphics.pod deleted file mode 100644 index 579b6d7..0000000 --- a/Perl/Zinc/Graphics.pod +++ /dev/null @@ -1,1749 +0,0 @@ - -=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 buildZincItem(Z<>) - -=item B repeatZincItem(Z<>) - -=item B buildTabBoxItem(Z<>) - -=back - -=head3 2. Calculs de formes géométriques complexes - -=over - -=item B roundedRectangleCoords(Z<>) - -=item B hippodromeCoords(Z<>) - -=item B ellipseCoords(Z<>) - -=item B roundedCurveCoords(Z<>) - -=item B polygonCoords(Z<>) - -=item B polylineCoords(Z<>) - -=item B curveLineCoords>(Z<>) - -=item B pathLineCoords(Z<>) - -=item B shiftPathCoords(Z<>) - -=item B tabBoxCoords(Z<>) - -=back - -=head3 3. Création de relief et ombre portée - -=over - -=item B graphicItemRelief(Z<>) - -=item B graphicItemShadow(Z<>) - -=back - -=head3 4. Fonctions géométriques de base - -=over - -=item B perpendicularPoint(Z<>) - -=item B lineAngle(Z<>) - -=item B vertexAngle(Z<>) - -=item B arc_pts(Z<>) - -=item B rad_point(Z<>) - -=item B bezierCompute(Z<>) - -=item B bezierSegment(Z<>) - -=item B bezierPoint(Z<>) - -=back - -=head3 5. Gestion des ressources images - -=over - -=item B getPattern(Z<>) - -=item B getTexture(Z<>) - -=item B getImage(Z<>) - -=item B init_pixmaps(Z<>) - -=back - -=head3 6. Gestion des couleurs - -=over - -=item B setGradiants(Z<>) - -=item B zincItemPredominantColor(Z<>) - -=item B ZnColorToRGB(Z<>) - -=item B hexaRGBcolor(Z<>) - -=item B createGraduate(Z<>) - -=item B MedianColor(Z<>) - -=item B LightingColor(Z<>) - -=item B RGBtoLCH(Z<>) - -=item B LCHtoRGB(Z<>) - -=item B RGBtoHLS(Z<>) - -=item B HLStoRGB(Z<>) - -=back - -Z<> - -=head2 1. Création de composants graphiques - - -=over - -=item B(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 : - -=over - -=item B - - identifiant du widget zinc. - -=item B - - identifiant de l'item group parent. - - -=back - - -=item B : - - -=over - -=item B<-itemtype> => type - -Specifie le(s) type(s) d'item(s) souhaite(s). Peut etre celui d'un item -natif zinc (B, B, B, B, B, B), -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 - - coordonnees geometriques ou de position de l'item. - -=item B<-metacoords> => \%metatype_params - - 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) - - coordonnees geometriques ou de position de l'item. - -=item B<-params> => \%zinc_attr - - parametres zinc de l'item. - -=item B<-contours> => \@list - - arguments zinc d'ajout de contours . - -=item B<-clip> - - clipping d'un item group. - -=item B<-items> - - table d'items contenus dans un item group. -provoque un appel récursif de la fonction buildZincItem(). - -=item B<-texture> - - ajout d'une texture a l'item. - -=item B<-pattern> - - ajout d'un pattern a l'item. - -=item B<-relief> - - creation d'un relief a l'item a l'aide d'item zinc triangles. -Invoque la fonction du module Graphics graphicItemRelief() - -=item B<-shadow> - - creation d'une ombre portee a l'item. -Invoque la fonction du module Graphics graphicItemShadow() - -=item B<-repeat> - - 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> => (en degré) - -application d'une transformation zinc->rotate a l'item - -=item B<-addtags> - - liste de tags specifiques a ajouter aux parametre item -tags. - -=item B<-name> - - nom de l'item. - -=back - -=back - -Z<> - -=item B(widget, item, options); - -Répétition (clonage) d'un objet Zinc de representation. - -=over - -=item B : - -=over - -=item B - - identifiant du widget zinc. - -=item B - - identifiant de l'item zinc a dupliquer. - -=back - -=item B : - -=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 de rotation en degré a appliquer entre 2 copies. - -=item B<-copytag> => - -ajout d'un tag indexé pour chaque copie. - -=item B<-params> => \%zinc_attr - -Paramétrage specialises de chaque copie - - -=back - -=back - -Z<> - -=item B(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 : - -=over - -=item B - - identifiant du widget zinc. - -=item B - - identifiant de l'item group parent. - -=back - -=item B : - -=over - -=item B<-coords> => [[x0,y0],[x1,y1]] - - coordonnées haut-gauche et bas-droite de la BoundingBox du tabBox. - -=item B<-numpages> - - 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'|| - -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'| - -hauteur des onglets (par défaut 'auto') - -=item B<-tabshift> => 'auto'| - -offset de biseau entre la base et le haut de l'onglet (par défaut 'auto'). - -=item B<-overlap> => 'auto'| - -offset de décalage entre 2 onglets (par défaut 'auto'). - -=item B<-radius> - - rayon des arrondis d'angle des onglets. (par défaut 0) - -=item B<-corners> - - liste d'application du raccord aux angles sous forme booleenne -0 = sans raccord 1 = avec raccord. - -=item B<-params> => \%zinc_attr - - parametres zinc de l'item. - -=item B<-texture> - - ajout d'une texture a l'item. - -=item B<-relief> - - creation d'un relief pour les pages du tabBox. -Invoque la fonction du module Graphics graphicItemRelief() - -=item B<-tabtitles> - - table de hash de définition des titres d'onglets (label, params). - -=item B<-pageitems> - - 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(coords, options); - -Retourne les coordonnées (curve) d'un rectangle à coins arrondis - -=over - -=item B : - -=over - -=item B => [[x0,y0],[x1,y1]] - - coordonnées haut-gauche et bas-droite du rectangle. - -=back - -=item B : - -=over - -=item B<-radius> - - 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(coords, options); - -Retourne les coordonnées (curve) d'un hippodrome - -=over - -=item B : - -=over - -=item B => [[x0,y0],[x1,y1]] - - coordonnées haut-gauche et bas-droite du rectangle exinscrit à l'hippodrome. - -=back - -=item B : - -=over - -=item B<-orientation> => - -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> => - -troncatures des cotés circulaires de l'hippodrome. - -=back - -=back - -Z<> - -=item B(coords, options); - -Retourne les coordonnées (curve) d'une ellipse - -=over - -=item B : - -=over - -=item B => [[x0,y0],[x1,y1]] - - coordonnées haut-gauche et bas-droite du rectangle exinscrit. - -=back - -=item B : - -=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(coords, options); - -Retourne les coordonnées d'une curve à coins arrondis. - -=over - -=item B : - -=over - -=item B => [[x0,y0],...[xn,yn]] - - coordonnées de la curve - -=back - -=item B : - -=over - -B<-radius> : -rayon de raccord des angles. par defaut 0 - -B<-corners> : -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(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 : - -=over - -=item B => [x0,y0] - - coordonnées du centre du cercle exinscrit au polygone/étoile - -=back - -=item B : - -=over - -B<-numsides> : nombre de cote du polygone ou nombre de branches de l'etoile - -B<-radius> : rayon du cercle exinscrit au polygone - -B<-startangle> : angle de depart du trace de la figure - -B<-inner_radius> : rayon du cercle des points 'internes' de l'etoile - -B<-corner_radius> : rayon des raccords d'angles - -B<-corners> : 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(coords, options); - -Retourne les coordonnées d'une polyline, ligne 'brisée' multi-segments -avec raccords angulaires optionnels. - -=over - -=item B : - -=over - -=item B => [[x0,y0],...[xn,yn]] - - liste de coordonnées des sommets de la polyline - -=back - -=item B : - -=over - -B<-radius> : -rayon global de raccord des angles. par defaut 0 - -B<-corners> : -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> : -Liste des rayons de raccord des angles. - -=back - -=back - -Z<> - -=item B(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 : - -=over - -=item B => [[x0,y0],...[xn,yn]] - - coordonnées de la curve - -=back - -=item B : - -=over - -B<-width> : -é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> : -distance décalage de départ dans le dessin du tireté (par défaut 0) - -=back - -=back - -Z<> - -=item B(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 : - -=over - -=item B => [[x0,y0],...[xn,yn]] - - liste de coordonnées du path - -=back - -=item B : - -=over - -B<-closed> : -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> : -Largeur du décalage de ligne (par défaut 2). - -=back - -=back - -Z<> - -=item B(coords, %options); - -retourne les coordonnées curve de 'décalage' par rapport à un path donné. - -=over - -=item B : - -=over - -=item B => [[x0,y0],...[xn,yn]] - - liste de coordonnées du path - -=back - -=item B : - -=over - -B<-closed> : -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> : -Largeur du décalage de ligne (par défaut 1). - -=back - -=back - -Z<> - -=item B(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 : - -=over - -=item B => [[x0,y0],[x1,y1]] - - coordonnées haut-gauche et bas-droite de la BoundingBox du tabBox. - -=back - -=item B : - -=over - -B<-numpages> : 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'| 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'| hauteur des onglets (par défaut 'auto') - -B<-tabshift> : 'auto' offset de biseau entre la base et le haut de l'onglet (par défaut 'auto'). - -B<-overlap> : 'auto' offset de décalage entre 2 onglets (par défaut 'auto'). - -B<-radius> : -rayon des arrondis d'angle des onglets. (par défaut 0) - -B<-corners> : 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(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 : - -=over - -=item B - -identifiant du widget zinc. - -=item B - -identifiant de l'item zinc à mettre en relief. - -=back - -=item B : - -=over - -B<-closed> : 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> : position externe ou interne du relief (defaut 'inside'). - -B<-color> : couleur de base du relief (défaut couleur dominante de l'item). - -B<-smoothed> : lissage des 'facettes' du relief (par defaut 1). - -B<-lightangle> : angle de la lumiere (par defaut attribut -lightangle du widget). - -B<-width> : largeur du 'contour' relief. - -B<-fine> : mode precision courbe de bezier (par defaut 0 : auto-ajustee). - -=back - -=back - -Z<> - -=item B(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 : - -=over - -B : identifiant du widget zinc - -B : identifiant de l'item zinc - -=back - -B : - -=over - -B<-opacity> : poucentage d'opacite de l'ombre (par defaut 50). - -B<-distance> : distance de projection de l'ombre (par defaut 10). - -B<-enlarging> : 'grossissement' cone de projection (defaut 0). - -B<-color> : couleur de l'ombre (par defaut black). - -B<-lightangle> : angle de la lumiere (par defaut attribut -lightangle du widget). - -B<-width> : 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(point, line); - -retourne les coordonnées du point perpendiculaire abaissé d'un point sur une ligne. - -=over - -=item B : - -=over - -=item B => [x, y] - - coordonnées du point de référence. - -=item B => [[x0, y0],[x1, y1]] - - liste de coordonnées des deux points de la ligne de référence. - -=back - -=back - -Z<> - - -=item B(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 : - -=over - -=item B => [x, y] - - coordonnées du point de départ du segment (ou centre de référence). - -=item B => [x, y] - - coordonnées du point de fin du segment (ou point 'circulaire' de référence). - -=back - -=back - -Z<> - -=item B(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 : - -=over - -=item B => [x, y] - - coordonnées du point de départ du segment (ou centre de référence). - -=item B => [x, y] - - coordonnées du point de fin du segment (ou point 'circulaire' de référence). - -=back - -=back - -Z<> - -=item B(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 : - -=over - -=item B => [x, y] - - coordonnées du premier point de définition de l'angle. - -=item B => [x, y] - - coordonnées du deuxième point de définition de l'angle (sommet). - -=item B => [x, y] - - coordonnées du troisième point de définition de l'angle. - - -=back - -=back - -Z<> - -=item B(center, radius, %options); - -Calcul des points constitutifs d'un arc - -=over - -=item B : - -=over - -=item B
=> [x0,y0] - - coordonnées du centre de l'arc. - -=item B - - rayon de l'arc. - -=back - -=item B : - -=over - -=item B<-angle> - - angle de départ (en degré) de l'arc (par défaut 0) - -=item B<-extent> - - delta angulaire (en degré) de l'arc (par défaut 360) - -=item B<-step> - - pas de progression angulaire (en degré) de calcul des points (par défaut 10). - -=back - -=back - -Z<> - -=item B(center, radius, angle); - -Retourne le point circulaire défini par centre-rayon-angle. - -=over - -=item B : - -=over - -=item B
=> [x0,y0] - - coordonnées du centre de l'arc. - -=item B - - rayon de l'arc. - -=item B - - angle (en degré) du point de circonférence avec le centre du cercle. - -=back - -=back - -Z<> - -=item B(coords, %options); - -Calcul d'une approximation de segment (Quadratique ou Cubique) de bezier. - -=over - -=item B : - -=over - -=item B - - Liste de coordonnées des points définissant le segment de bezier. - -=back - -=item B : - -=over - -=item B<-tunits> - - nombre pas de division des segments bezier (par défaut 20) - -=item B<-skipend> - - ne pas retourner le dernier point du segment (pour chaînage de segments). - -=back - -=back - -Z<> - -=item B(t, coords); - -Calcul d'un point du segment (Quadratique ou Cubique) de bezier. -t représentation du temps (de 0 à 1). -coords = (P1, 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 : 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 : - -=over - -=item B - - (de 0 à 1) représentation du temps. - -=item B - - Liste de coordonnées des points définissant le segment de bezier. - -=back - -=back - -Z<> - - -=item B(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 : - -=over - -=item B - - Liste de coordonnées des points définissant le segment de bezier. - -=back - -=item B : - -=over - -=item B<-precision> - - seuil limite du calcul d'approche de la courbe (par défaut .2) - -=item B<-skipend> - - 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(filename, %options); - -retourne et partage la ressource image bitmap en l'initialisant et la stockant si première utilisation. - -=over - -=item B : - -=over - -=item B - - non du fichier bitmap pattern - -=back - -=item B : - -=over - -=item B<-storage> - - référence de la table de stockage privée des patterns. - -=back - -=back - -Z<> - -=item B(widget, filename, %options); - -retourne et partage la ressource image texture en l'initialisant et la stockant si première utilisation. - -=over - -=item B : - -=over - -=item B - - identifiant du widget zinc. - -=item B - - non du fichier image texture - -=back - -=item B : - -=over - -=item B<-storage> - - référence de la table de stockage privée des textures. - -=back - -=back - -Z<> - -=item B(widget, filename, %options); - -retourne et partage la ressource image en l'initialisant et la stockant si première utilisation. - -=over - -=item B : - -=over - -=item B - - identifiant du widget zinc. - -=item B - - non du fichier image - -=back - -=item B : - -=over - -=item B<-storage> - - référence de la table de stockage privée des images. - -=back - -=back - -Z<> - -=item B(widget, filenames, %options); - -Initialise et stocke un ensemble d'images. - -=over - -=item B : - -=over - -=item B - - identifiant du widget zinc. - -=item B - - Liste des fichier images à initialiser. - -=back - -=item B : - -=over - -=item B<-storage> - - 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(widget, gradients); - -Création de gradiants nommés Zinc - -=over - -=item B : - -=over - -=item B - - identifiant du widget Zinc - -=item B - - référence de la table de définition des gradiants zinc ('non' => 'zincGradient'). - -=back - -=back - -Z<> - -=item B(widget, item); - -retourne la couleur dominante d'un item ('barycentre' gradiant fillcolor). - -=over - -=item B : - -=over - -=item B - - identifiant du widget Zinc - -=item B - - identifiant de l'item zinc. - -=back - -=back - -Z<> - -=item B(color1, color2, rate); - -calcul d'une couleur intermédiaire défini par un ratio ($rate) entre 2 couleurs. - -=over - -=item B : - -=over - -=item B - - première couleur - -=item B - - première couleur - -=item B - - (de 0 à 1) position de la couleur intermédiaire. - -=back - -=back - -Z<> - -=item B(widget, steps, refcolors, repeat); - -création d'un jeu de couleurs intermédiaires (dégradé) entre n couleurs. - -=over - -=item B : - -=over - -=item B - - identifiant du widget Zinc - -=item B - - nombre totale de couleurs retournées. - -=item B - - liste de couleurs servant à créer le dégradé. - -=item B - - 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(color, newL); - -Modification d'une couleur par sa composante luminosité (exemple relief). - -=over - -=item B : - -=over - -=item B - - couleur au format zinc. - -=item B - - (de 0 à 1) nouvelle valeur de luminosité. - -=back - -=back - -Z<> - -=item B(zncolor); - -conversion d'une couleur Zinc hexa au format RGBA (255,255,255,100). - -=over - -=item B : - -=over - -=item B - - couleur au format hexa zinc (#ffffff ou #ffffffffffff). - -=back - -=back - -Z<> - -=item B(r, g, b); - -conversion d'une couleur de l'espace RGB à l'espace CIE LCH°. - -=over - -=item B : - -=over - -=item B - - (de 0 à 1) valeur de la composante rouge de la couleur RGB. - -=item B - - (de 0 à 1) valeur de la composante verte de la couleur RGB. - -=item B - - (de 0 à 1) valeur de la composante bleue de la couleur RGB. - -=back - -=back - -Z<> - -=item B(L, C, H); - -conversion d'une couleur de l'espace CIE LCH° à l'espace RGB. - -=over - -=item B : - -=over - -=item B - - (de 0 à 1) valeur de la composante luminosité de la couleur CIE LCH. - -=item B - -C : (de 0 à 1) valeur de la composante saturation de la couleur CIE LCH - -=item B - -H : (de 0 à 1) valeur de la composante teinte de la couleur CIE LCH - -=back - -=back - -Z<> - -=item B(r, g, b); - -conversion d'une couleur de l'espace RGB à l'espace HLS. - -=over - -=item B : - -=over - -=item B - - (de 0 à 1) valeur de la composante rouge de la couleur RGB. - -=item B - - (de 0 à 1) valeur de la composante verte de la couleur RGB. - -=item B - - (de 0 à 1) valeur de la composante bleue de la couleur RGB. - -=back - -=back - -Z<> - -=item B(H, L, S); - -conversion d'une couleur de l'espace HLS à l'espace RGB. - -=over - -=item B : - -=over - -=item B - - (de 0 à 1) valeur de la composante teinte de la couleur HLS. - -=item B - -C : (de 0 à 1) valeur de la composante luminosité de la couleur HLS. - -=item B - -H : (de 0 à 1) valeur de la composante saturation de la couleur HLS. - -=back - -=back - -Z<> - -=item B(r, g, b, a); - -conversion d'une couleur RGBA (255,255,255,100) au format Zinc '#ffffff'. - -=over - -=item B : - -=over - -=item B - - (0 à 255) composante rouge de la couleur rgba. - -=item B - - (0 à 255) composante verte de la couleur rgba. - -=item B - - (0 à 255) composante bleue de la couleur rgba. - -=item B - - (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 diff --git a/Perl/Zinc/Logo.pm b/Perl/Zinc/Logo.pm deleted file mode 100644 index 486c904..0000000 --- a/Perl/Zinc/Logo.pm +++ /dev/null @@ -1,238 +0,0 @@ -package Tk::Zinc::Logo; - -#--------------------------------------------------------------- -# -# Module : Logo.pm -# $Id$ -# -# Copyright (C) 2001-2003 -# Centre d'Études de la Navigation Aérienne -# Authors: Jean-Luc Vinot -# -#--------------------------------------------------------------- - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use strict; -use Carp; -use Math::Trig; - - -my @Gradiants; - -# paramètres de construction graphique -my %builder = (-gradset => {'logoshape' => '=axial 270 |#ffffff;100 0 28|#66848c;100 96|#7192aa;100 100', - 'logopoint' => '=radial -20 -20 |#ffffff;100 0|#f70000;100 48|#900000;100 80|#ab0000;100 100', - 'logoptshad' => '=path 0 0 |#770000;64 0|#770000;70 78|#770000;0 100', - }, - - -shape => {-form => {-itemtype => 'curve', - -coords => [[0,0],[106,0],[106,58],[122,41],[156,41],[131,69],[153,99],[203,41], - [155,41],[155,0],[225.71,0],[251.34,0,'c'],[265.17,29.63,'c'], - [248.71,49.27],[202,105],[246,105],[246,87],[246,59.385,'c'],[268.38,37,'c'], - [296,37],[323.62,37,'c'],[346,59.385,'c'],[346,87],[346,148],[305,148], - [305,87],[305,82.58,'c'],[301.42,79,'c'],[297,79],[292.58,79,'c'], - [289,82.58,'c'],[289,87],[289,150],[251,150],[251,130],[251,125.58,'c'], - [247.42,122,'c'],[243,122],[243,122],[238.58,122,'c'],[235,125.58,'c'], - [235,130],[235,150],[168.12,150],[144.7,150,'c'],[132.38,122.57,'c'], - [147.94,105.06],[148,105],[120,105],[104,81],[104,105],[74,105],[74,41], - [52,41],[52,105],[20,105],[20,41],[0,41]], - - -contour => ['add', -1, [[395,78],[395,37],[364.62,37,'c'],[340,61.62,'c'],[340,92], - [340,93],[340,123.38,'c'],[364.62,148,'c'],[395,148],[409,148], - [409,107],[395,107],[386.72,107,'c'],[380,100.28,'c'],[380,92], - [380,93],[380,84.72,'c'],[386.72,78,'c'],[395,78]]], - - - -params => {-closed => 0, - -filled => 1, - -visible => 1, - -fillcolor => 'logoshape', - -linewidth => 2.5, - -linecolor => '#000000', - -priority => 40, - -fillrule => 'nonzero', - -tags => ['zinc_shape'], - }, - }, - - -shadow => {-clone => '-form', - -translate => [6, 6], - -params => {-fillcolor => '#000000;18', - -linewidth => 0, - -priority => 20, - }, - }, - }, - - -point => {-coords => [240, 96], - -params => {-alpha => 80, - -priority => 100, - }, - - -form => {-itemtype => 'arc', - -coords => [[-20, -20], [20, 20]], - -params => {-priority => 50, - -filled => 1, - -linewidth => 1, - -linecolor => '#a10000;100', - -fillcolor => 'logopoint', - -closed => 1, - }, - }, - - -shadow => {-clone => '-form', - -translate => [5, 5], - -params => {-fillcolor => 'logoptshad', - -linewidth => 0, - -priority => 20, - }, - }, - }, - ); - - - -sub new { - my $proto = shift; - my $type = ref($proto) || $proto; - my %params = @_; - - my $self = {}; - bless ($self, $type); - if (exists $params{'-widget'}) { - $self->{'-widget'} = $params{'-widget'}; - } else { - croak "in Tk::Zinc::Logo constructor, the -widget attribute must be defined\n"; - } - $self->{'-parent'} = (exists $params{'-parent'}) ? $params{'-parent'} : 1; - $self->{'-priority'} = (exists $params{'-priority'}) ? $params{'-priority'} : 500; - $self->{'-position'} = (exists $params{'-position'}) ? $params{'-position'} : [0, 0]; - $self->{'-scale'} = (exists $params{'-scale'}) ? $params{'-scale'} : [1, 1]; - - $self->drawLogo(); - - return bless $self, $type; -} - - - -sub drawLogo { - my ($self) = @_; - my $zinc = $self->{'-widget'}; - my $parent = $self->{'-parent'}; - my $priority = $self->{'-priority'}; - - - if ($builder{'-gradset'}) { - while (my ($name, $gradiant) = each( %{$builder{'-gradset'}})) { - # création des gradiants nommés - $zinc->gname($gradiant, $name) unless $zinc->gname($name); - push(@Gradiants, $name); - } - } - - # création des groupes logo - # logogroup : groupe de coordonnées - my $logogroup = $self->{'-item'} = $zinc->add('group', $parent, -priority => $priority); - $zinc->coords($logogroup, $self->{'-position'}) if ($self->{'-position'}); - - # group de scaling - my $group = $self->{'-scaleitem'} = $zinc->add('group', $logogroup); - $zinc->scale($group, @{$self->{'-scale'}}) if ($self->{'-scale'}); - - - # création de l'item shape (Zinc) - my $formstyle = $builder{'-shape'}->{'-form'}; - $self->ajustLineWidth($formstyle->{'-params'}); - my $shape = $zinc->add('curve', $group, - $formstyle->{'-coords'}, - %{$formstyle->{'-params'}}, - ); - - $zinc->contour($shape, @{$formstyle->{'-contour'}}); - - # ombre portée de la shape - my $shadstyle = $builder{'-shape'}->{'-shadow'}; - my $shadow = $zinc->clone($shape, %{$shadstyle->{'-params'}}); - $zinc->translate($shadow, @{$shadstyle->{'-translate'}}) if ($shadstyle->{'-translate'}); - - # réalisation du point - my $pointconf = $builder{'-point'}; - my $ptgroup = $zinc->add('group', $group, %{$pointconf->{'-params'}}); - $zinc->coords($ptgroup, $pointconf->{'-coords'}); - - my $pointstyle = $pointconf->{'-form'}; - my $point = $zinc->add('arc', $ptgroup, - $pointstyle->{'-coords'}, - %{$pointstyle->{'-params'}}, - ); - - my $shadpoint = $zinc->clone($point, %{$shadstyle->{'-params'}}); - $shadstyle = $pointconf->{'-shadow'}; - $zinc->translate($shadpoint, @{$shadstyle->{'-translate'}}); - -} - - -sub ajustLineWidth { - my ($self, $style, $scale) = @_; - - if ($style->{'-linewidth'}) { - my ($sx, $sy) = @{$self->{'-scale'}}; - my $linewidth = $style->{'-linewidth'}; - if ($linewidth >= 2) { - my $ratio = ($sx > $sy) ? $sy : $sx; - $style->{'-linewidth'} = $linewidth * $ratio; - } - } -} - -1; - -__END__ - -=head1 NAME - -Tk::Zinc::Logo - a perl module for drawing the TkZinc logo. - - -=head1 SYNOPSIS - - use Tk::Zinc::Logo; - my $zinc = MainWindow->new()->Zinc()->pack; - my $logo = $zinc->ZincLogo([options]); - - - -=head1 OPTIONS - -=over - -=item B<-parent> => zinc group - -Specify the parent group. Default is 1. - -=item B<-position> => [x, y] - -Specify the relative position of the logo in its parent group. Default is [0, 0]. - -=item B<-priority> => integer - -Specify the priority of the logo in its parent group. Default is 500. - -=item B<-scale> => [sx, sy] - -Scecify the xscale and yscale factors of the logo. Default is [1, 1]. - - -=back - - -=head1 AUTEUR - -Jean-Luc Vinot - - - diff --git a/Perl/Zinc/Text.pm b/Perl/Zinc/Text.pm deleted file mode 100644 index 63e9573..0000000 --- a/Perl/Zinc/Text.pm +++ /dev/null @@ -1,262 +0,0 @@ -package Tk::Zinc::Text; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - - -sub new { - my $proto = shift; - my $type = ref($proto) || $proto; - my ($zinc) = @_; - my $self = {}; - - $zinc->bind('text', '<1>' => sub {startSel($zinc)}); - $zinc->bind('text', '<2>' => sub {pasteSel($zinc)}); - $zinc->bind('text', '' => sub {extendSel($zinc)}); - $zinc->bind('text', '' => sub {extendSel($zinc)}); - $zinc->bind('text', '' => sub { - my $e = $zinc->XEvent(); - my($x, $y) = ($e->x, $e->y); - $zinc->select('adjust', 'current', "\@$x,$y"); }); - $zinc->bind('text', '' => sub {moveCur($zinc, -1);}); - $zinc->bind('text', '' => sub {moveCur($zinc, 1);}); - $zinc->bind('text', '' => sub {setCur($zinc, 'up');}); - $zinc->bind('text', '' => sub {setCur($zinc, 'down');}); - $zinc->bind('text', '' => sub {setCur($zinc, 'bol');}); - $zinc->bind('text', '' => sub {setCur($zinc, 'bol');}); - $zinc->bind('text', '' => sub {setCur($zinc, 'eol');}); - $zinc->bind('text', '' => sub {setCur($zinc, 'eol');}); - $zinc->bind('text', '' => sub {setCur($zinc, 0);}); - $zinc->bind('text', '' => sub {setCur($zinc, 'end');}); - $zinc->bind('text', '' => sub {insertKey($zinc);}); - $zinc->bind('text', '' => sub {insertKey($zinc);}); - $zinc->bind('text', '' => sub { insertChar($zinc, chr(10)); }); - $zinc->bind('text', '' => sub {textDel($zinc, -1)}); - $zinc->bind('text', '' => sub {textDel($zinc, -1)}); - $zinc->bind('text', '' => sub {textDel($zinc, 0)}); - - bless ($self, $type); - return $self; -} - - -sub pasteSel { - my ($w) = @_; - my $e = $w->XEvent; - my($x, $y) = ($e->x(), $e->y()); - my @it = $w->focus(); - - if (@it != 0) { - eval { $w->insert(@it, "\@$x,$y", $w->SelectionGet()); }; - } -} - - -sub insertChar { - my ($w, $c) = @_; - my @it = $w->focus(); - my @selit = $w->select('item'); - - if (@it == 0) { - return; - } - - if ((scalar(@selit) == scalar(@it)) && - ($selit[0] eq $it[0]) && ($selit[1] eq $it[1])) { - $w->dchars(@it, 'sel.first', 'sel.last'); - } - $w->insert(@it, 'insert', $c); -} - - -sub insertKey { - my ($w) = @_; - my $c = $w->XEvent->A(); - - if ((ord($c) < 32) || (ord($c) == 128)) { - return; - } - - insertChar($w, $c); -} - - -sub setCur { - my ($w, $where) = @_; - my @it = $w->focus(); - - if (@it != 0) { - $w->cursor(@it, $where); - } -} - - -sub moveCur { - my ($w, $dir) = @_; - my @it = $w->focus(); - my $index; - - if (@it != 0) { - $index = $w->index(@it, 'insert'); - $w->cursor(@it, $index + $dir); - } -} - - -sub startSel { - my($w) = @_; - my $e = $w->XEvent; - my($x, $y) = ($e->x(), $e->y()); - my $part = $w->currentpart(1); - - $w->cursor('current', $part, "\@$x,$y"); - $w->focus('current', $part); - $w->Tk::focus(); - $w->select('from', 'current', $part, "\@$x,$y"); -} - - -sub extendSel { - my($w) = @_; - my $e = $w->XEvent; - my($x, $y) = ($e->x, $e->y); - my $part = $w->currentpart(1); - - $w->select('to', 'current', $part, "\@$x,$y"); -} - - -sub textDel { - my($w, $dir) = @_; - my @it = $w->focus(); - my @selit = $w->select('item'); - my $ind; - - if (@it == 0) { - return; - } - - if ((scalar(@selit) == scalar(@it)) && - ($selit[0] eq $it[0]) && ($selit[1] eq $it[1])) { - $w->dchars(@it, 'sel.first', 'sel.last'); - } - else { - $ind = $w->index(@it, 'insert') + $dir; - $w->dchars(@it, $ind, $ind) if ($ind >= 0); - } -} - -1; -__END__ - -=head1 NAME - -Tk::Zinc::Text - Zinc extension for easing text input on text item or on fields - -=head1 SYNOPSIS - - use Tk::Zinc::Text; - - $zinc = $mw->Zinc(); - new Tk::Zinc::Text ($zinc); - .... - $zinc->addtag('text', 'withtag', $a_text); - $zinc->addtag('text', 'withtag', $a_track); - $zinc->addtag('text', 'withtag', $a_waypoint); - $zinc->addtag('text', 'withtag', $a_tabular); - -=head1 DESCRIPTION - -This module implements text input with the mouse and keyboard 'a la emacs'. -Text items must have the 'text' tag and must of course be sensitive. -Track, waypoint and tabular items have fields and these fields can -be edited the same way. Only sensitive fields can be edited. the following -interactions are supported: - -=over 2 - -=item B - -To set the cursor position - -=item B - -To paste the current selection - -=item B - -To make a selection - -=item B - -To extend the current selection - -=item B - -To extend the current selection - -=item B, B - -To move the cursor to the left or to the right - -=item B, B - -To move the cursor up or down a line - -=item B, B - -To move the cursor at the begining of the line - -=item B, B - -To move the cursor at the end of the line - -=item B, B> - -To move the cursor at the beginning / end of the text - -=item B, B - -To delete the char just before the cursor - -=item B - -To delete the char just after the cursor - -=item B - -To insert a return char. This does not validate the input! - -=back - -=head1 BUGS - -No known bugs at this time. If you find one, please report them to the authors. - -=head1 SEE ALSO - -perl(1), Tk(1), Tk::Zinc(3), zinc-demos(1) - -=head1 AUTHORS - -Patrick Lecoanet -(and some documentation by Christophe Mertz ) - -=head1 COPYRIGHT - -CENA (C) 2002 - -Tk::Zinc::Text is part of Zinc and 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 MER­CHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library -General Public License for more details. - -=head1 HISTORY - -June 2002 : initial release with Zinc-perl 3.2.6 - -=cut diff --git a/Perl/Zinc/Trace.pm b/Perl/Zinc/Trace.pm deleted file mode 100644 index f115171..0000000 --- a/Perl/Zinc/Trace.pm +++ /dev/null @@ -1,227 +0,0 @@ -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1995-1999 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, subject -# to additional disclaimer in Tk/license.terms due to partial -# derivation from Tk8.0 sources. -# -# Copyright (c) 2002 CENA, C.Mertz to trace all -# Tk::Zinc methods calls as well as the args in a human readable -# form. Updated by D.Etienne. -# -# This package overloads the Tk::Methods function in order to trace -# every Tk::Zinc method call in your application. -# -# This may be very usefull when your application segfaults and -# when you have no idea where this happens in your code. -# -# $Id$ -# -# To trap Tk::Zinc errors, use rather the Tk::Zinc::TraceErrors package. -# -# for using this file do some thing like : -# perl -MTk::Zinc::Trace myappli.pl - -package Tk::Zinc::Trace; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use vars qw( $ForReplay ); - -use Tk; -use strict; -use Tk::Zinc::TraceUtils; - -my $WidgetMethodfunction; -my %moduleOptions; - - -BEGIN { - if (defined $ZincTraceErrors::on && $ZincTraceErrors::on == 1) { - print STDERR "Tk::Zinc::Trace: incompatible package Tk::Zinc::TraceErrors is already ". - "loaded (exit 1)\n"; - exit 1; - } - print "## Tk::Zinc::Trace ON\n"; - $ZincTrace::on = 1; - require Getopt::Long; - Getopt::Long::Configure('pass_through'); - Getopt::Long::GetOptions(\%moduleOptions, 'code'); - $ForReplay=1 if defined $moduleOptions{code} ; - select STDOUT; $|=1; ## for flushing the trace output - # save current Tk::Zinc::InitObject function; it will be invoked in - # overloaded one (see below) - use Tk; - use Tk::Zinc; - $WidgetMethodfunction = Tk::Zinc->can('WidgetMethod'); - -} - -print "## following trace should be very close to a replay-script code\n" if $ForReplay; - -my $ZincCounter= ""; -my %ZincHash; - -#sub Tk::Zinc { -# print "CREATING Zinc : @_"; -# &$ZincCreationMethodfunction; -#} - -sub Tk::Zinc::WidgetMethod { - my ($zinc, $name, @args) = @_; - if (defined $Tk::Zinc::Trace::off and $Tk::Zinc::Trace::off > 0) { - return &$WidgetMethodfunction(@_) if $WidgetMethodfunction; - } - my ($package, $filename, $line) = caller(1); - $package="" unless defined $package; - $filename="" unless defined $filename; - $line="" unless defined $line; - my $widget; - if (defined $ZincHash{$zinc}) { - $widget = $ZincHash{$zinc}; - } elsif ($ZincCounter) { - $ZincHash{$zinc} = '$zinc'.$ZincCounter; - $widget = '$zinc'.$ZincCounter; - $ZincCounter++; - } else { - $ZincHash{$zinc} = '$zinc'; - $widget = '$zinc'; - $ZincCounter=1; # for the next zinc - } - - if ($ForReplay) { - print "$widget->$name"; - } else { - print "TRACE: $filename line $line $name"; - } - - &printList(@args); - # invoke function possibly overloaded in other modules - if (wantarray()) { - my @res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction; - if ($ForReplay) { - print ";\n"; - } else { - print " RETURNS "; - &printList (@res); - print "\n"; - } - $zinc->update; - return @res; - } else { - my $res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction; - if ($ForReplay) { - print ";\n"; - } else { - print " RETURNS "; - &printItem ($res); - print "\n"; - } - $zinc->update; - return $res; - } -} - -1; - - -__END__ - -=head1 NAME - -Tk::Zinc::Trace - A module to trace all Tk::Zinc method calls - -=head1 SYNOPSIS - -use Tk::Zinc::Trace; -$Tk::Zinc::Trace:ForReplay = 1; - -or - -perl -MTk::Zinc::Trace YourZincBasedScript.pl [--code] - -=head1 DESCRIPTION - -When loaded, this module overloads a Tk mechanism so that every -Tk::Zinc method call will be traced. Every call will also be followed by a -$zinc->update() so that the method call will be effectively treated. - -This module can be very effective for debugging when Tk::Zinc -core dumps and you have no clue which method call can be responsible for. If -you just want to trace Tk::Zinc errors when calling a method you -should rather use the Tk::Zinc::TraceErrors module - -The global variable $Tk::Zinc::Trace:off can be used to trace some specific blocks. If set to 1, traces are deactivated, if set to 0, traces are reactivated. - -If the global variable $Tk::Zinc::Trace:ForReplay is set or if the --code -option is set in the second form, the printout will be very close to re-executable -code, like this: - - ## following trace should be very close to a replay-script code - $zinc->configure(-relief => 'sunken', -borderwidth => 3, - -width => 700, -font => 10x20, -height => 600); - $zinc->add('rectangle', 1, [10, 10, 100, 50], - -fillcolor => 'green', -filled => 1, -linewidth => 10, - -relief => 'roundridge', -linecolor => 'darkgreen'); - $zinc->add('text', 1, -font => -adobe-helvetica-bold-r-normal-*-120-*-*-*-*-*-* => - -text => 'A filled rectangle with a "roundridge" relief border of 10 pixels.', - -anchor => 'nw', -position => [120, 20]); - $zinc->add('track', 1, 6, - -labelformat => 'x82x60+0+0 x60a0^0^0 x32a0^0>1 a0a0>2>1 x32a0>3>1 a0a0^0>2', - -position => [20, 120], -speedvector => [40, -10], -speedvectormark => 1, -speedvectorticks => 1); - $zinc->coords(4, [20, 120]); - - -If not (the default), the printout will be more informtative, giving -the following information: - -=over 6 - -=item * the source filename where the method has been invoked - -=item * the line number in the source file - -=item * the TkZinc method name - -=item * the list of arguments in a human-readable form - -=item * the returned value - -=back - -The trace will look like: - - ## Tk::Zinc::Trace ON - TRACE: /usr/lib/perl5/Tk/Widget.pm line 196 configure(-relief => 'sunken', -borderwidth => 3, -width => 700, -font => 10x20, -height => 600) RETURNS undef - TRACE: Perl/demos/demos/zinc_lib/items.pl line 21 add('rectangle', 1, [10, 10, 100, 50], -fillcolor => 'green', -filled => 1, -linewidth => 10, -relief => 'roundridge', -linecolor => 'darkgreen') RETURNS 2 - TRACE: Perl/demos/demos/zinc_lib/items.pl line 25 add('text', 1, -font => -adobe-helvetica-bold-r-normal-*-120-*-*-*-*-*-* => -text => 'A filled rectangle with a "roundridge" relief border of 10 pixels.', -anchor => 'nw', -position => [120, 20]) RETURNS 3 - TRACE: Perl/demos/demos/zinc_lib/items.pl line 36 add('track', 1, 6, -labelformat => 'x82x60+0+0 x60a0^0^0 x32a0^0>1 a0a0>2>1 x32a0>3>1 a0a0^0>2', -position => [20, 120], -speedvector => [40, -10], -speedvectormark => 1, -speedvectorticks => 1) RETURNS 4 - -=head1 AUTHOR - -C.Mertz and D.Etienne - -=head1 CAVEATS and BUGS - -This module cannot be used when Tk::Zinc::TraceErrors is already in use. - -As every Tk::Zinc method call is followed by an ->update call, this may -dramatically slowdown an application. The trade-off is between application -run-time and developper debug-time. - -When using an output "code-like" they are still part of the output which is -not executable code. However, the ouptut could be easily and manually -edited to be executable perl code. - -=head1 COPYRIGHT - -See Tk::Zinc copyright; LGPL - -=head1 SEE ALSO - -L, L. L. - -=cut diff --git a/Perl/Zinc/TraceErrors.pm b/Perl/Zinc/TraceErrors.pm deleted file mode 100644 index e74f28a..0000000 --- a/Perl/Zinc/TraceErrors.pm +++ /dev/null @@ -1,149 +0,0 @@ -# -# Copyright (c) 1992-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1995-1999 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, subject -# to additional disclaimer in Tk/license.terms due to partial -# derivation from Tk8.0 sources. -# -# Copyright (c) 2003 CENA, D.Etienne to trace all -# Tk::Zinc errors. -# -# This package overloads the Tk::Zinc::WidgetMethods function in order to -# to trap errors by calling every Tk::Zinc method in an eval() block. -# -# This may be very usefull when your application encounters errors such as -# "error .... at /usr/lib/perl5/Tk.pm line 228". With ZincTraceErrors, the -# module name, the line number and the complete error messages are reported -# for each error. -# -# $Id$ -# -# When you have no idea where this happens in your code or when your -# application segfaults, use the Tk::Zinc::Trace package which traces every -# Tk::Zinc method call. -# -# for using this file do some thing like : -# perl -MTk::Zinc::TraceErrors myappli.pl - -package Tk::Zinc::TraceErrors; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use strict; -use Tk::Zinc::TraceUtils; - -my $WidgetMethodfunction; -my $bold = ""; -my $_bold = ""; - -BEGIN { - my $bold = ""; - my $_bold = ""; - - if (defined $ZincTrace::on and $ZincTrace::on == 1) { - print STDERR $bold."Tk::Zinc::TraceErrors: incompatible package Tk::Zinc::Trace is already ". - "loaded".$_bold." (exit 1)\n"; - exit 1; - } - print $bold."Tk::Zinc::TraceErrors is ON".$_bold."\n"; - $ZincTraceErrors::on = 1; - select STDOUT; $|=1; ## for flushing the trace output - # save current Tk::Zinc::InitObject function; it will be invoked in - # overloaded one (see below) - use Tk; - use Tk::Zinc; - $WidgetMethodfunction = Tk::Zinc->can('WidgetMethod'); - -} - -sub Tk::Zinc::WidgetMethod { - my ($zinc, $name, @args) = @_; - my ($package, $filename, $line) = caller(1); - $package="" unless defined $package; - $filename="" unless defined $filename; - $line="" unless defined $line; - # invoke function possibly overloaded in other modules - my ($res, @res); - if (wantarray()) { - eval {@res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction;}; - } else { - eval {$res = &$WidgetMethodfunction(@_) if $WidgetMethodfunction;}; - } - if ($@) { - print $bold."error:".$_bold." $filename line $line $name"; - &printList (@args); - my $msg = $@; - $msg =~ s/at .*//g; - print " ".$bold."returns".$_bold." $msg\n"; - } - if (wantarray()) { - return @res; - } else { - return $res; - } -} - - - -1; - - -__END__ - -=head1 NAME - -Tk::Zinc::TraceErrors - A module to trace all Tk::Zinc method calls which generate an error - -=head1 SYNOPSIS - -use Tk::Zinc::TraceErrors; - -or - -perl -MTk::Zinc::TraceErrors YourZincBasedScript.pl - -=head1 DESCRIPTION - -When loaded, this module overloads a Tk mechanism so that every -Tk::Zinc method call will be traced if it provokes an error. The execution -will then continue. - -This module can be very effective for debugging and application, specially -when Tk gives an unusuable error message such as ".... errors in Tk.pm line 228" - -=over 6 - -=item * the source filename where the method has been invoked - -=item * the line number in the source file - -=item * the TkZinc method name - -=item * the list of arguments in a human-readable form - -=item * the error message - -=back - -=head1 AUTHOR - -D.Etienne and C.Mertz - -=head1 CAVEAT - -This module cannot be used when Tk::Zinc::Trace is already in use. - -=head1 COPYRIGHT - -See Tk::Zinc copyright; LGPL - -=head1 SEE ALSO - -L, L. L. - -=cut - diff --git a/Perl/Zinc/TraceUtils.pm b/Perl/Zinc/TraceUtils.pm deleted file mode 100644 index 8a3bc76..0000000 --- a/Perl/Zinc/TraceUtils.pm +++ /dev/null @@ -1,111 +0,0 @@ -package Tk::Zinc::TraceUtils; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Font; -use Tk::Photo; - -require Exporter; -@ISA = qw(Exporter); -@EXPORT = qw(printItem printArray printList Item Array List); - -use strict; - -sub printItem { - print &Item (@_); -} - -sub printArray { - print &Array (@_); -} - -sub printList { - print &List (@_); -} - - -### to print something -sub Item { - my ($value) = @_; - my $ref = ref($value); -# print "VALUE=$value REF=$ref\n"; - if ($ref eq 'ARRAY') { - return Array ( @{$value} ); - } elsif ($ref eq 'CODE') { - return "{CODE}"; - } elsif ($ref eq 'Tk::Photo') { -# print " **** $value ***** "; - return "Tk::Photo(\"". scalar $value->cget('-file') . "\")"; - } elsif ($ref eq 'Tk::Font') { - return "'$value'"; - } elsif ($ref eq '') { # scalar - if (defined $value) { - if ($value =~ /^-?\d+(\.\d*(e[+-]?\d+)?)?$/ or # -1. or 1.0 - $value =~ /^-[a-zA-Z]([\w])*$/ # -option1 or -option-1 - ) { - return $value; - } elsif ($value eq '' - or $value =~ /\s/ - or $value =~ /^[a-zA-Z]/ - or $value =~ /^[\W]/ - ) { - return "'$value'"; - } else { - return $value; - } - } else { - return "_undef"; - } - } else { # some class instance - return $value; - } - -} # end Item - - -### to print a list of something -sub Array { - my (@values) = @_; - if (! scalar @values) { - return "[]"; - } - else { # the list is not empty - my $res = "["; - while (@values) { - my $value = shift @values; - $res .= &Item ($value); - $res .= ", " if (@values); - } - return $res. "]" ; - } - -} # end Array - - -sub List { - my $res = "("; - while (@_) { - my $v = shift @_; - $res .= Item ($v); - if (@_ > 0) { - ## still some elements - if ($v =~ /^-\d+$/) { - $res .= ", "; - } elsif ($v =~ /^-\w+$/) { - $res .= " => "; - } else { - $res .= ", "; - } - } - } - return $res. ")"; - -} # end List - - -1; - - - diff --git a/Perl/debug/.cvsignore b/Perl/debug/.cvsignore deleted file mode 100644 index 625327a..0000000 --- a/Perl/debug/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -Makefile -Makefile.old -blib -pm_to_blib diff --git a/Perl/demos/.cvsignore b/Perl/demos/.cvsignore deleted file mode 100644 index c58b391..0000000 --- a/Perl/demos/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -Makefile -pm_to_blib diff --git a/Perl/demos/Makefile.PL b/Perl/demos/Makefile.PL deleted file mode 100644 index 9b22bab..0000000 --- a/Perl/demos/Makefile.PL +++ /dev/null @@ -1,7 +0,0 @@ -use ExtUtils::MakeMaker; -WriteMakefile( - 'EXE_FILES' => ['zinc-demos'], - 'PMLIBDIRS' => [ qw( Tk/demos/zinc_pm Tk/demos/zinc_contrib_lib - Tk/demos/zinc_data Tk/demos/zinc_lib ) ], - ); - diff --git a/Perl/demos/Tk/demos/zinc_contrib_lib/README b/Perl/demos/Tk/demos/zinc_contrib_lib/README deleted file mode 100644 index 4decc6a..0000000 --- a/Perl/demos/Tk/demos/zinc_contrib_lib/README +++ /dev/null @@ -1 +0,0 @@ -This directory is for deposing zinc demos contribs \ No newline at end of file diff --git a/Perl/demos/Tk/demos/zinc_contrib_lib/TripleRotatingWheel.pl b/Perl/demos/Tk/demos/zinc_contrib_lib/TripleRotatingWheel.pl deleted file mode 100644 index 42bb2d1..0000000 --- a/Perl/demos/Tk/demos/zinc_contrib_lib/TripleRotatingWheel.pl +++ /dev/null @@ -1,445 +0,0 @@ -#!/usr/bin/perl -# TripleRotatingWheel gambling game contributed by "zentara" - -# Idea derived from the wheelOfFortune.pl demo by D. Etienne etienne@cena.fr -# $Id$ - - -use Tk; -use Tk::Zinc; - -my @win =(); # an array to store winning wheel values, can range from - # () to (1,1,1) - -# We create a classical root widget called MainWindow; then we create Zinc -# widget child with size, color and relief attributes, and we display it using -# the geometry manager called 'pack'. -my $mw = MainWindow->new; -$mw->geometry("700x600"); - -$mw->resizable(0,0); - -my $zinc = $mw->Zinc(-width => 700, -height => 565, - -backcolor => 'black', - -borderwidth => 3, -relief => 'sunken'); -$zinc->pack; - -# Then we create a gray filled rectangle, in which we will display explain text. -$zinc->add('rectangle', 1 , [200, 400, 490, 490], - -linewidth => 2, - -filled => 1, - -fillcolor => 'SkyBlue', - ); -my $text = $zinc->add('text', 1, - -position => [350, 445], - -anchor => 'center', - ); - -$zinc->add('rectangle', 1 , [250,275,450,325], #(xpos1,ypos1,xpos2,ypos2) - -linewidth => 2, - -filled => 1, - -fillcolor => 'Orange', - ); - -my $wintext = $zinc->add('text', 1, - -position => [350, 300], - -anchor => 'center', - ); - -#create winning wheel markers -#create first triangle, then clone and translate -my $tr1 = $zinc->add('triangles', 1, - [0,20,20,20,10,50], - -fan => 1, - -colors => 'Orange', - -visible => 1, - ); -my $tr2 = $zinc->clone($tr1); -my $tr3 = $zinc->clone($tr1); -$zinc->translate($tr1,130,0); -$zinc->translate($tr2,340,0); -$zinc->translate($tr3,550,0); - - - -# Create the Wheel object (see Wheel.pm) -my $wheel1 = Wheel->new($zinc, 350, 500, 100); #start xpos,ypos,mag -my $wheel2 = Wheel->new($zinc, 350, 500, 100); -my $wheel3 = Wheel->new($zinc, 350, 500, 100); - -# Display comment -&comment("Strike any key to begin"); -&wincomment("READY"); - -# Create Tk binding -$mw->Tk::bind('', \&openmode); - - -MainLoop; - -# Callback bound to '' event when wheel is unmapped -sub openmode { - # set binding to unmap the wheel - $mw->Tk::bind('', \&closemode); - # set binding to rotate the hand - $zinc->bind($wheel1, '<1>', sub {spin()}); - $zinc->bind($wheel2, '<1>', sub {spin()}); - $zinc->bind($wheel3, '<1>', sub {spin()}); - # map the wheel - $wheel1->show(140, 150); - $wheel2->show(350, 150); - $wheel3->show(560, 150); - - # and then inform user - &comment("Click on any wheel to play.\n". - "Strike any key to hide the wheels."); -} - -sub spin { - return if $wheel1->ismoving; - return if $wheel2->ismoving; - return if $wheel3->ismoving; - - @win=(); - &wincomment("PLAYING"); - $wheel1->rotatewheel(int rand(360)); - $wheel2->rotatewheel(int rand(360)); - $wheel3->rotatewheel(int rand(360)); -# print "\@win->@win\n"; - } - - -# Callback bound to '' event when wheel is already mapped -sub closemode { - return if $wheel1->ismoving; - return if $wheel2->ismoving; - return if $wheel3->ismoving; - - # set binding to map the wheel - $mw->Tk::bind('', \&openmode); - # unmap the wheel - $wheel1->hide(350, 400); - $wheel2->hide(350, 400); - $wheel3->hide(350, 400); - # and then inform user - &comment("Strike any key to show the wheel"); -} - -# Just display comment -sub comment { - my $string = shift; - $zinc->itemconfigure($text, -text => $string); -} - -# display winning comment -sub wincomment { - my $string = shift; - $zinc->itemconfigure($wintext, -text => $string); -} - -sub displaywin { - if($#win == -1){&wincomment("NO WIN")} - if($#win == 0){&wincomment("SINGLE")} - if($#win == 1){&wincomment("DOUBLE")} - if($#win == 2){&wincomment("TRIPLE")} - - #restore disabled mouse click for next spin - $zinc->bind($wheel1, '<1>', sub {spin()}); - $zinc->bind($wheel2, '<1>', sub {spin()}); - $zinc->bind($wheel3, '<1>', sub {spin()}); -} - -#============================================================================= -# Wheel Class -#============================================================================= -package Wheel; - -use strict 'vars'; -use Carp; -#==================== -# Object constructor -#==================== -sub new { - my ($proto, $widget, $x, $y, $radius) = @_; - - # object attributes - my $self = { - 'widget' => $widget, # widget reference - 'origin' => [$x, $y], # origin coordinates - 'radius' => $radius, # wheel radius - 'topgroup' => undef, # top Group item - 'itemclip' => undef, # id of item which clips the wheel - 'angle' => 0, # delta angle - 'stepsnumber' => 20, # animations parameters - 'afterdelay' => 30, - 'shrinkrate' => 0.8, # zoom parameters - 'zoomrate' => 1.1, - - }; - bless $self; - - # First, we create a new Group item for the wheel. Why a Group item ? - # At least two reasons. Wheel object consists of several Zinc items, - # we'll see below; it moves when it is mapped or unmapped, grows when - # you hit the jackpot. So, it's more easy to apply such transformations - # to a structured items set, using Group capability, rather than apply - # to each item separately or using canvas-like Tags mechanism. - # Second reason refers to clipping. When it is mapped or unmapped, wheel - # object is drawn inside a circle with variant radius; clipping is a - # specific property of Group item - - # That's why we create a Group item in the top group, and set its - # coordinates. - $self->{topgroup} = $widget->add('group', 1, -visible => 0); - $widget->coords($self->{topgroup}, [$x,$y]); - -#print " start widget coords-> $x $y\n"; - - # All the following items will be created in this group... - # Create the invisible Arc item used to clip the wheel, centered on the - # group origin. - $self->{itemclip} = $widget->add('arc', $self->{topgroup}, - [-$radius, -$radius, $radius, $radius], - -visible => 0, - ); - $widget->itemconfigure($self->{topgroup}, -clip => $self->{itemclip}); - - # Create the wheel with 6 filled Arc items centered on the group origin - my $i = 0; - for my $color (qw(magenta blue cyan green yellow red)) { - $widget->add('arc', $self->{topgroup}, - [-$radius, -$radius, $radius, $radius], - -visible => 1, - -filled => 1, - -closed => 1, - -extent => 60, - -pieslice => 1, - -fillcolor => $color, - -linewidth => 1, - -startangle => 60*$i , - -tags => [$self], - ); - $i++; - } - - # Create the Text item representing the jackpot. - $widget->add('text', $self->{topgroup}, - -position => [0, -$radius+20], - -font => - '-adobe-helvetica-bold-o-normal--34-240-100-100-p-182-iso8859-1', - -anchor => 'center', - -text => "\$", - ); - - - # Then we unmap the wheel; in fact, Group item is translated and its - # clipping circle is shrunk to a point. - $self->_clipAndTranslate($self->{shrinkrate}**$self->{stepsnumber}); - return $self; -} - -#================ -# Public methods -#================ - -# Return 1 if wheel is moving (opening or closing animation) -sub ismoving { - my $self = shift; - return 1 if $self->{opening} or $self->{closing} or $self->{turning}; -} - -# Display wheel with animation effect -sub show { - my ($self, $x, $y) = @_; - # simple lock management - return if $self->{opening} or $self->{closing}; - $self->{opening} = 1; - # start animation - $self->_open($x, $y, 0); -} - - -# Unmap wheel with animation effect -sub hide { - my ($self, $x, $y) = @_; - # simple lock management - return if $self->{opening} or $self->{closing}; - $self->{closing} = 1; - # start animation - $self->_close($x, $y, 0); -} - - -# Just rotate the hand with animation effect. -sub rotatewheel { - my $self = shift; - #print "wheel-> $self->{topgroup}"; - my $angle = shift; -#print " angle->$angle\n"; - - return if $self->{turning}; - -#prevent "double-clicking", so mouse is disabled -#until current play is over -$zinc->bind($wheel1, '<1>', sub {}); -$zinc->bind($wheel2, '<1>', sub {}); -$zinc->bind($wheel3, '<1>', sub {}); - - $angle = 0 unless $angle; - my $oldangle = $self->{angle}; - $self->{angle} = $angle; - - if ((330 < $angle)||($angle < 30)) { - $self->{fortune} = 1; - push (@win, $self->{fortune}); - } - $self->_rotatewheel(2*3.1416*($angle + 1440 - $oldangle)/360); - #the 1440 above gives at least 2 full spins each play -} - -#================= -# Private methods -#================= - -# Generate opening animation; see below _clipAndTranslate method for -# Zinc specific use. -sub _open { - my ($self, $x, $y, $cnt) = @_; - my $widget = $self->{widget}; - my $group = $self->{topgroup}; - # first step of animation - if ($cnt == 0) { - $widget->itemconfigure($group, -visible => 1); - my @pos = $widget->coords($group); - $x = ($x - $pos[0])/$self->{stepsnumber}; - $y = ($y - $pos[1])/$self->{stepsnumber}; - # last step - } elsif ($cnt == $self->{stepsnumber}) { - $self->{opening} = undef; - return; - } - $cnt++; - # move and grow the wheel - $self->_clipAndTranslate(1/$self->{shrinkrate}, $x, $y); - # process the animation using the 'after' Tk defering method - $widget->after($self->{afterdelay}, sub {$self->_open($x, $y, $cnt)}); -} - - -# Generate closing animation; see below _clipAndTranslate method for -# Zinc specific use. -sub _close { - my ($self, $x, $y, $cnt) = @_; - my $widget = $self->{widget}; - my $group = $self->{topgroup}; - # first step of animation - if ($cnt == 0) { - my @pos = $widget->coords($group); - $x = ($x - $pos[0])/$self->{stepsnumber}; - $y = ($y - $pos[1])/$self->{stepsnumber}; - # last step - } elsif ($cnt == $self->{stepsnumber}) { - $widget->itemconfigure($group, -visible => 0); - $self->{closing} = undef; - return; - } - $cnt++; - # move and shrink the wheel - $self->_clipAndTranslate($self->{shrinkrate}, $x, $y); - # process the animation using the 'after' Tk defering method - $widget->after($self->{afterdelay}, sub {$self->_close($x, $y, $cnt)}); - -&main::wincomment("READY"); -} - -# Generate hand rotation animation. -sub _rotatewheel { - my ($self, $angle, $cnt) = @_; - my $widget = $self->{widget}; - my $group = $self->{topgroup}; - -#grab position of widget -my @pos = $widget->coords($group); -my $x = ($pos[0]); -my $y = ($pos[1]); - - $self->{turning} = 1; - # first step of animation - if (not $cnt) { - $angle /= $self->{stepsnumber}; - - # last step - } elsif ($cnt == $self->{stepsnumber}) { - if ($self->{fortune}) { - $self->_fortune; - } else { - $self->{turning} = undef; - } - - &main::displaywin(); - return; - } - $cnt++; - # use 'rotation' Zinc method. - - $widget->rotate($self->{topgroup}, $angle); -# process the animation using the 'after' Tk defering method - -#needed to keep wheel stationary while rotating -$widget->coords($self->{topgroup},[$x,$y]); - - $widget->after($self->{afterdelay}, sub {$self->_rotatewheel($angle, $cnt)}); - -} - -# Generate growing animation to notify jackpot -sub _fortune { - my ($self, $cnt) = @_; - $cnt = 0 unless $cnt; - my $zf; - my $widget = $self->{widget}; - my $group = $self->{topgroup}; - my @pos = $widget->coords($group); - # last step of animation - if ($cnt == 6) { - $self->{fortune} = undef; - $self->{turning} = undef; - return; - # event steps : wheel grows - } elsif ($cnt == 0 or $cnt % 2 == 0) { - $zf = $self->{zoomrate}; - # odd steps : wheel is shrunk - } else { - $zf = 1/$self->{zoomrate}; - } - $cnt++; - - # Now, we apply scale transformation to the Group item, using the 'scale' - # Zinc method. Note that we reset group coords before scaling it, in order - # that the origin of the transformation corresponds to the center of the - # wheel. When scale is done, we restore previous coords of group. - $widget->coords($group, [0, 0]); - $widget->scale($group, $zf, $zf); - $widget->coords($group, \@pos); - - # process the animation using the 'after' Tk defering method - $widget->after(100, sub {print "\007";$self->_fortune($cnt)}); - &main::displaywin(); -} - - -# Update group clipping and translation, using 'scale' and 'translate' -# Zinc methods. -sub _clipAndTranslate { - my ($self, $shrinkfactor, $x, $y) = @_; - $x = 0 unless $x; - $y = 0 unless $y; - $self->{widget}->scale($self->{itemclip}, $shrinkfactor, $shrinkfactor); - if ($Tk::Zinc::VERSION lt "3.297") { - $self->{widget}->translate($self->{topgroup}, $x, $y); - } else { - my ($xc, $yc) = $self->{widget}->coords($self->{topgroup}); - $self->{widget}->coords($self->{topgroup}, [$xc + $x, $yc + $y]); - } -} -1; diff --git a/Perl/demos/Tk/demos/zinc_data/background_texture.gif b/Perl/demos/Tk/demos/zinc_data/background_texture.gif deleted file mode 100644 index 9bb4c11..0000000 Binary files a/Perl/demos/Tk/demos/zinc_data/background_texture.gif and /dev/null differ diff --git a/Perl/demos/Tk/demos/zinc_data/hegias_parouest_TE.vid b/Perl/demos/Tk/demos/zinc_data/hegias_parouest_TE.vid deleted file mode 100644 index 1755d80..0000000 Binary files a/Perl/demos/Tk/demos/zinc_data/hegias_parouest_TE.vid and /dev/null differ diff --git a/Perl/demos/Tk/demos/zinc_data/paper-grey.gif b/Perl/demos/Tk/demos/zinc_data/paper-grey.gif deleted file mode 100644 index 96775b5..0000000 Binary files a/Perl/demos/Tk/demos/zinc_data/paper-grey.gif and /dev/null differ diff --git a/Perl/demos/Tk/demos/zinc_data/paper-grey1.gif b/Perl/demos/Tk/demos/zinc_data/paper-grey1.gif deleted file mode 100644 index fe8c8ef..0000000 Binary files a/Perl/demos/Tk/demos/zinc_data/paper-grey1.gif and /dev/null differ diff --git a/Perl/demos/Tk/demos/zinc_data/paper.gif b/Perl/demos/Tk/demos/zinc_data/paper.gif deleted file mode 100644 index 3247d35..0000000 Binary files a/Perl/demos/Tk/demos/zinc_data/paper.gif and /dev/null differ diff --git a/Perl/demos/Tk/demos/zinc_data/stripped_texture.gif b/Perl/demos/Tk/demos/zinc_data/stripped_texture.gif deleted file mode 100644 index a0b842e..0000000 Binary files a/Perl/demos/Tk/demos/zinc_data/stripped_texture.gif and /dev/null differ diff --git a/Perl/demos/Tk/demos/zinc_data/videomap_orly b/Perl/demos/Tk/demos/zinc_data/videomap_orly deleted file mode 100644 index 17f9c66..0000000 Binary files a/Perl/demos/Tk/demos/zinc_data/videomap_orly and /dev/null differ diff --git a/Perl/demos/Tk/demos/zinc_data/videomap_paris-w_90_2 b/Perl/demos/Tk/demos/zinc_data/videomap_paris-w_90_2 deleted file mode 100644 index fb32a5b..0000000 Binary files a/Perl/demos/Tk/demos/zinc_data/videomap_paris-w_90_2 and /dev/null differ diff --git a/Perl/demos/Tk/demos/zinc_data/zinc.gif b/Perl/demos/Tk/demos/zinc_data/zinc.gif deleted file mode 100644 index b7eac16..0000000 Binary files a/Perl/demos/Tk/demos/zinc_data/zinc.gif and /dev/null differ diff --git a/Perl/demos/Tk/demos/zinc_data/zinc_anti.gif b/Perl/demos/Tk/demos/zinc_data/zinc_anti.gif deleted file mode 100644 index 4d1cda9..0000000 Binary files a/Perl/demos/Tk/demos/zinc_data/zinc_anti.gif and /dev/null differ diff --git a/Perl/demos/Tk/demos/zinc_lib/MagicLens.pl b/Perl/demos/Tk/demos/zinc_lib/MagicLens.pl deleted file mode 100644 index a625254..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/MagicLens.pl +++ /dev/null @@ -1,325 +0,0 @@ -#!/usr/bin/perl -#----------------------------------------------------------------------------------- -# -# MagicLens.pl -# -# This small demo is based on Zinc::Graphics.pm for creating -# the graphic items. -# The magnifyer effect is obtained with the help of clipping, -# and some glass effect is based on color transparency through -# a triangles item bordering the magnifier -# -# Authors: Jean-Luc Vinot -# -# $Id$ -#----------------------------------------------------------------------------------- - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use Tk::Zinc::Graphics; -use Getopt::Long; -use strict 'vars'; - -# the original fonts are not available everywhere, even if they are free! -my $font_9b = '7x13bold'; # '-cenapii-bleriot mini-bold-r-normal--9-90-75-75-p-*-iso8859-15'; -my $font_8 = '7x13'; #'-cenapii-bleriot mini-book-r-normal--8-80-75-75-p-*-iso8859-15'; -my ($dx, $dy); - -my @basiccolors = (['Jaune','#fff52a','#f1f1f1','#6a6611'], - ["Jaune\nOrangé",'#ffc017','#cfcfcf','#6b510a'], - ['Orangé','#ff7500','#a5a5a5','#622d00'], - ['Rouge','#ff2501','#8b8b8b','#620e00'], - ['Magenta','#ec145d','#828282','#600826'], - ["Violet\nRouge",'#a41496','#636363','#020940'], - ["Violet\nBleu",'#6a25b6','#555555','#2a0f48'], - ['Bleu','#324bde','#646464','#101846'], - ['Cyan','#0a74f0','#818181','#064a9a'], - ["Bleu\nVert",'#009bb4','#969696','#006474'], - ['Vert','#0fa706','#979797','#096604'], - ["Jaune\nVert",'#9dd625','#c9c9c9','#496311']); - -my $circle_coords = [[0,-30],[-16.569,-30,'c'],[-30,-16.569,'c'],[-30,0],[-30,16.569,'c'],[-16.569,30,'c'],[0,30], - [16.569,30,'c'],[30,16.569,'c'],[30,0],[30,-16.569,'c'],[16.569,-30,'c'],[0,-30]]; - - -# MagicLens -my %lensitems = ('back' => {-itemtype => 'arc', - -coords => [[-100, -100],[100,100]], - -params => {-priority => 10, - -closed => 1, - -filled => 1, - -visible => 0, - -tags => ['lensback'], - }, - }, - 'light' => {-itemtype => 'pathline', - -metacoords => {-type => 'polygone', - -coords => [0, 0], - -numsides => 36, - -radius => 100, - -startangle => 240, - }, - -linewidth => 10, - -shifting => 'in', - -closed => 1, - -graduate => {-type => 'double', - -colors => [['#ffffff;0', '#6666cc;0', '#ffffff;0'], - ['#ffffff;100', '#333399;50', '#ffffff;100']], - }, - -params => {-priority => 50, - }, - }, - 'bord' => {-itemtype => 'hippodrome', - -coords => [[-100, -100],[100, 100]], - -params => {-priority => 100, - -closed => 1, - -filled => 0, - -linewidth => 2, - -linecolor => '#222266;80' - }, - - }, - ); - - -# creation de la fenetre principale -my $mw = MainWindow->new(); -$mw->geometry("1000x900+0+0"); -$mw->title('Color Magic Lens'); - - -# creation du widget Zinc -my $zinc = $mw->Zinc(-render => 1, - -width => 1000, - -height => 900, - -borderwidth => 0, - -lightangle => 140, - -borderwidth => 0, - ); -$zinc->pack(-fill => 'both', -expand => 1); - -my $texture = $zinc->Photo(-file => Tk->findINC('demos/zinc_data/paper-grey1.gif')); -$zinc->configure(-tile => $texture); - -# création des 2 vues -my $normview = $zinc->add('group', 1, -priority => 100); -my $lensview = $zinc->add('group', 1, -priority => 200); -my $infoview = $zinc->add('group', $lensview); - -my $zoom=1.20; -$zinc->scale($infoview, $zoom, $zoom); - -my $lenstexture = $zinc->Photo(-file => Tk->findINC('demos/zinc_data/paper-grey.gif')); -$zinc->add('rectangle', $infoview, - [[0,0],[1000,900]], - -filled => 1, - -fillcolor => '#000000', - -tile => $lenstexture, - -linewidth => 0, - ); - -my $gradbar; - -my $x = 60; -for (my $i = 0; $i < 12; $i++) { - - # ajout d'un groupe dans chacune des les 2 vues - my $cgroup = $zinc->add('group', $normview); - $zinc->coords($cgroup, [$x, 60]); - my $lgroup = $zinc->add('group', $infoview); - $zinc->coords($lgroup, [$x, 60]); - - # références de la couleur : name, Zncolor saturée, ZnColor désaturée, ZnColor d'ombrage - my ($colorname, $saturcolor, $greycolor, $shadcolor) = @{$basiccolors[$i]}; - - # échantillon référence couleur saturée + relief - my $refgrad = "=radial -12 -20|#ffffff 0|".$saturcolor." 40|".$shadcolor." 100"; - my $refitem = $zinc->add('curve', $cgroup, - $circle_coords, - -filled => 1, - -fillcolor => $refgrad, - -linewidth => 2, - -priority => 100 - ); - - # clone dans le group infoview - my $clone = $zinc->clone($refitem); - $zinc->chggroup($clone, $lgroup); - - # label couleur (infoview) - $zinc->add('text', $lgroup, - -priority => 200, - -position => [0, 0], - -text => $colorname, - -anchor => 'center', - -alignment => 'center', - -font => $font_9b, - -spacing => 2, - ); - - # dégradé de la couleur vers le gris de même luminosité - my $bargrad = "=axial 270|".$saturcolor."|".$greycolor; - - # création des échantillons de couleur (curve multi-contours) - $gradbar = $zinc->add('curve', $cgroup, - [], - -closed => 1, - -filled => 1, - -fillcolor => $bargrad, - -linewidth => 2, - -priority => 20, - -fillrule => 'nonzero' - ); - - # définition des couleurs du dégradé (saturation 100% -> 0%) - my $zncolors = &createGraduate($zinc, 11, [$saturcolor, $greycolor]); - # on retire les valeurs alphas - foreach (@{$zncolors}){ ($_) = split /;/, $_;} - - # réalisation des pas de dégradé (saturation -> désaturation) - my $c; - for ($c = 0; $c < 11; $c++) { - - # couleur du pas - my $color = $zncolors->[$c]; - - # item zinc de l'exemple couleur - my $sample = $zinc->clone($refitem, -fillcolor => $color); - $zinc->translate($sample, 0, 65*($c+1)); - - # ajout à la curve multi-contours - $zinc->contour($gradbar, 'add', 1, $sample); - - # déplacement vers le groupe info - $zinc->chggroup($sample, $lgroup); - - # label texte (% saturation + ZnColor) - my $txtcolor = ((10 - $c)*10)."%\n$color"; - $zinc->add('text', $lgroup, - -priority => 200, - -position => [0, ($c + 1)* 65], - -text => $txtcolor, - -anchor => 'center', - -alignment => 'center', - -font => $font_8, - -spacing => 2, - ); - } - - - $x += 80; -} - -# création de la MagicLens -my $lensgroup = $zinc->add('group', 1, - -priority => 300, - -atomic => 1, - -tags => ['lens'], - ); -$zinc->coords($lensgroup, [300, 110]); -&lensMove(0,0); - -# items graphiques -while (my ($name, $style) = each(%lensitems)) { - &buildZincItem($zinc, $lensgroup, %{$style}); -} - -# clipping lensview -my $lenszone = $zinc->clone('lensback', -tags => ['lenszone']); -$zinc->chggroup($lenszone, $lensview, 1); -$zinc->itemconfigure($lensview, -clip => $lenszone); - -# consigne globale -my $consigne = $zinc->add('text', 1, - -position => [30, 840], - -text => ", , and keys or \nMove the Magic Color Lens behind the color gradiants\nto see the ZnColor value of Hue/saturation\n", - -font => $font_8, - -alignment => 'left', - -color => '#ffffff', - -spacing => 2, - ); - -my $cclone = $zinc->clone($consigne, -font => $font_9b); -$zinc->chggroup($cclone, $infoview); - -&setBindings; - - -MainLoop; -#----------------------------------------------------------------------- fin de MAIN - - -sub setBindings { - $zinc->bind('lens', '<1>', sub {&lensStart();}); - $zinc->bind('lens', '', sub {&lensMove();}); - $zinc->bind('lens', '', sub {&lensStop();}); - - $mw->Tk::focus(); - - # Up, Down, Right, Left : Translate - $mw->Tk::bind('', sub {lensTranslate('up');}); - $mw->Tk::bind('', sub {lensTranslate('down');}); - $mw->Tk::bind('', sub {lensTranslate('left');}); - $mw->Tk::bind('', sub {lensTranslate('right');}); -} - - - - -#----------------------------------------------------------------------------------- -# Callback CATCH de sélection (début de déplacement) de la lentille -#----------------------------------------------------------------------------------- -sub lensStart { - my $ev = $zinc->XEvent; - ($dx, $dy) = (0 - $ev->x, 0 - $ev->y); - -} - - -#----------------------------------------------------------------------------------- -# Callback MOVE de déplacement de la lentille -#----------------------------------------------------------------------------------- -sub lensMove { - my ($tx, $ty) = @_; - - if (defined $tx and defined $ty) { - # interaction clavier - $zinc->translate('lens', $tx, $ty); - $zinc->translate('lenszone', $tx, $ty); - - } else { - my $ev = $zinc->XEvent; - $zinc->translate('current', $ev->x + $dx, $ev->y +$dy); - $zinc->translate('lenszone', $ev->x + $dx, $ev->y +$dy); - ($dx, $dy) = (0 - $ev->x, 0 - $ev->y); - } - - my ($lx, $ly) = $zinc->coords('lens'); - $zinc->coords($infoview, [$lx * (1-$zoom), $ly * (1-$zoom)]); - -} - - -#----------------------------------------------------------------------------------- -# Callback RELEASE de relaché (fin de déplacement) de la lentille -#----------------------------------------------------------------------------------- -sub lensStop { - &lensMove; -} - -sub lensTranslate { - my $way = shift; - - my $dx = ($way eq 'left') ? -10 : ($way eq 'right') ? 10 : 0; - my $dy = ($way eq 'up') ? -10 : ($way eq 'down') ? 10 : 0; - - &lensMove($dx, $dy); - -} - - - -1; diff --git a/Perl/demos/Tk/demos/zinc_lib/Zetris.pl b/Perl/demos/Tk/demos/zinc_lib/Zetris.pl deleted file mode 100644 index f6c9df0..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/Zetris.pl +++ /dev/null @@ -1,972 +0,0 @@ -#!/usr/bin/perl -# Zinc port of TkTetris from Slaven Rezic -#------------------------------------------------------------------------------ -# -# Zetris - A Zinc Toy-Appli based on cool TkTetris from Slaven Rezic -# -# $Id$ -# -# Copyright (C) 2002 Centre d'Etudes de la Navigation Aérienne -# Author: Marcellin Buisson -# -# Hacked from Original Code to adapt to Tk::Zinc Widget : -# -#------------------------------------------------------------------------------ -# -# Author: Slaven Rezic -# -# Copyright (C) 1997, 1999, 2000, 2002 Slaven Rezic. All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -# Mail: slaven.rezic@berlin.de -# WWW: http://www.rezic.de/eserte/ -# -#------------------------------------------------------------------------------ - -#------------------------------------------------------------------------------ -# What are the differences with the original TkTetris ? -#------------------------------------------------------------------------------ -# -# - This TkTetris-like uses a tk widget similar to the canvas -# and called "Zinc". Zinc bring to Tk widgets openGL features -# like transparency, color gradients, scaling. -# So to use Zetris graphic enhancement, you need openGL capability. -# Zinc comes with other features like grouping and clipping. -# -# - A color gradient is used for Zetris background, -# -# - Zetris balls are filled with transparently color gradients, -# (transparency is visible when balls fall over TkZinc logo) -# -# - Zetris balls have a little transparent shadow, -# -# - The TkZinc logo is animated by rotation and scaling effects, -# -# - Introducing of groups provided by Zinc for grouping items -# This feature is particularly useful for applying transformations, -# -# - The TkZinc logo over background isn't an image but only curves -# and color gradients (made by ) -# -# - Please feel free to provide any feedback to -# -# - CM: Zetris now works even without openGL. It is just ugly! -# -#------------------------------------------------------------------------------ - -#------------------------------------------------------------------------------ -# ToDos : -# -# - Complete this basic version in a full playable game like tktetris. -# - Review conception through Zinc features. -# (using groups capabilities for drawing blocks for instance) -# - Adding special effects when completing a line or changing level. -# -#------------------------------------------------------------------------------ -use Tk; -use Tk::Zinc; -use strict; -use Tk::Zinc::Logo; - -package main; - -use Getopt::Long; - -use vars qw($VERSION); - -$VERSION = sprintf("%d.%00d", q$Revision$ =~ /(\d+)\.(\d+)/); - -my $max_size = 4; -my $nmbr_blks = 7; -my $width = 12; -my $height = 20; -my $geometry; - -my $level; -my $just_started = 1; -my $speed; -my $base_speed = 500; - -my $last_resize; -my $fontheight = 0; - -my $basefont - = sub { sprintf "-*-helvetica-medium-r-normal--%s-*", $_[0] }; -my $base2font - = sub { sprintf "-*-courier-medium-r-normal--%s-*", $_[0] }; - -my $blocks = 0; -my $lines = 0; -my $mylines = 0; - -my $pause = undef; -my $pause_w; -my $freefall = 0; -my $points = 0; -my $flat = 0; -my $moveable_drop = 0; - -my $old_win_height; -my $draw_shadow = 1; - -# Animation constants -my $afterdelay = 1; -my $stepsnumber = 10; -my $zoomrate = 1.1; - -my $active_block = undef; -my $active_block_nr = undef; -my $active_dir = undef; -my $next_block = undef; -my $next_block_nr = undef; -my $next_dir = undef; -my $posx = undef; -my $posy = undef; - -my $n = 0; - -my(%color_dark, %color_very_dark); -my %color_bright = - (2 => 'red', - 3 => 'green', - 4 => 'blue', - 5 => 'cyan', - 6 => 'yellow', - 7 => 'orange', - 8 => 'pink', - ); - -# Blocks matrix -my $block = - [[[qw(0 0 0 0)], - [qw(0 2 0 0)], - [qw(0 2 2 0)], - [qw(0 2 0 0)]], - [[qw(0 0 0 0)], - [qw(3 3 0 0)], - [qw(0 3 0 0)], - [qw(0 3 0 0)]], - [[qw(0 0 0 0)], - [qw(0 4 4 0)], - [qw(0 4 0 0)], - [qw(0 4 0 0)]], - [[qw(0 0 0 0)], - [qw(0 5 0 0)], - [qw(0 5 5 0)], - [qw(0 0 5 0)]], - [[qw(0 0 0 0)], - [qw(0 6 0 0)], - [qw(6 6 0 0)], - [qw(6 0 0 0)]], - [[qw(0 7 0 0)], - [qw(0 7 0 0)], - [qw(0 7 0 0)], - [qw(0 7 0 0)]], - [[qw(0 0 0 0)], - [qw(0 0 0 0)], - [qw(8 8 0 0)], - [qw(8 8 0 0)]], - ]; - -my $playfield; -reset_playfield(); - -my $step_x = 20; -my $step_y = 20; -my $boxsize_x = $step_x-2; -my $boxsize_y = $step_y-2; -my $block_border = int($boxsize_x/10); -my $help_top; - -my $top = MainWindow->new(); -$top->minsize(181, 83); -$top->title('Zetris'); - -{ - my $width_height_set = 0; - if ($geometry) - { - if ($geometry =~ /^(=?(\d+)x(\d+))?(([+-]\d+)([+-]\d+))?$/) - { - if (defined $2 and defined $3) - { - my($width, $height) = ($2, $3); - $top->GeometryRequest($width, $height); - $width_height_set++; - } - if (defined $5 and defined $6) - { - my($x, $y) = ($5, $6); - $top->geometry("$x$y"); - } - } - else - { - die "Can't parse geometry: $geometry"; - } - } - if (!$width_height_set) - { - $top->GeometryRequest($top->screenwidth, - $top->screenheight); - } -} - -my $base_level = 1; - -$level = level(); -$speed = speed(); - -resize_calc(); - -while(my($k, $v) = each %color_bright) - { - $color_dark{$k} = $top->Darken($v, 80); - $color_very_dark{$k} = $top->Darken($v, 60); - } - - -# Zinc Widget (openGl rendering option set to 1) -my $tetris = $top->Zinc(-width => $step_x*($width-2), - -height => $step_y*($height-1), - -backcolor => '#707070', - -lightangle => 130, - -render => 1, - )->pack; - -# Zetris will no more die if there is no openGL render. I did some minor -# modification (transparency, item priority) to make all needed item -# visible, even without alpha-transparency - -my $render = $tetris->cget(-render); - -my $shadow_group = $tetris->add('group',1, -visible => 1); - -my $pause_group = $tetris->add('group',1, -visible => 1); - -my $topgroup = 1; - -$tetris->pack(-fill => 'both', - -expand=> 1); - -$tetris->add('rectangle', - 1, # Zinc group - [0, 0,$step_x*($width-2) ,$step_y*($height-1)] , - -filled => 1, - -linewidth => 0, - -fillcolor => $render ? "=axial 90 |black;40|gray80;60" : "grey80", - -visible => 1); - -my $group = $tetris->add('group', 1, ); -my $logo = Tk::Zinc::Logo->new(-widget => $tetris, - -parent => $group, - -position => [$step_x*($width-2)/2-200, - $step_y*($height-1)/2], - ); - -$tetris->lower($group) if $render; - -my $score_group = $tetris->add('group',1, -visible => 1); -my $new = $tetris->add('text',$score_group, - -text => " $lines Line\n", - #-anchor => 'e', - -font => $basefont->($fontheight), - -position => [$width-2,10], - ); -$tetris->add('text',$score_group, - -text => "Sorry, without openGL,\nZtetris is just ugly.", - #-anchor => 'e', - -font => $basefont->($fontheight), - -position => [$width-2,100], - ) if !$render; - -$tetris->lower($score_group) if $render; - -my $timer = $top->after(speed(), sub { - $old_win_height = $top->height; - $just_started = 0; - action(); - }); - -make_key_bindings($top); - -print "\n***********************************************\n\n For help on the game toggle pause with 'p'\n\n***********************************************\n\n"; - -MainLoop; - -#------------------------------------------------------------------------ -sub reset_playfield - { - my $i; - # $fake_height: mit negativen Indices können die n-letzten Elemente - # angesprochen werden... - my $fake_height = $height+$max_size+1; - for $i (0 .. $fake_height-1) - { - $playfield->[$i][0] = 1; - my $j; - for $j (1 .. $width-2) - { - $playfield->[$i][$j] = 0; - } - $playfield->[$i][$width-1] = 1; - } - for $i (0 .. $width-1) - { - $playfield->[$height-1][$i] = 1; - } - } - -sub speed - { - my $speed = $base_speed - ($base_speed*$level)/20; - if ($speed <= 5) { $speed = 5 } - $speed; - } - -sub level - { - int($lines / 10) + 1 + $base_level - } - -sub resize_calc - { - $last_resize = time(); - my $win_height; - if ($just_started) - { - $win_height = $top->reqheight; - } - else - { - $win_height = $top->height; - } - $step_x = $step_y = int($win_height/($height+3)); - my $gap = ($step_x > 10 ? 2 : 1); - $boxsize_x = $step_x-$gap; - $boxsize_y = $step_y-$gap; - $block_border = int($boxsize_x/10); - if ($block_border < 1) { $block_border = 1 } - my @font_height = (10, 11, 12, 14, 17, 18, 20, 24, 25, 34); - my $req_fontheight = $win_height/30; - $fontheight = 0; - foreach (@font_height) - { - if ($_ > $req_fontheight) - { - $fontheight = $_; - last; - } - } - if (!$fontheight) { $fontheight = $font_height[$#font_height] } - # the following line has been commented out since - # it modify default font for every application - # launched by zinc-demos! CM 26/3/02 - # $top->optionAdd("*font" => $basefont->($fontheight)); - } - -sub make_key_bindings - { - my $top = shift; -# $top->bind('' => \&quit_game); -# $top->bind('' => \&quit_game); -# $top->bind('' => \&quit_game); - $top->bind('' => sub { move('left') }); - $top->bind('' => sub { move('right') }); - $top->bind('' => sub { move('antiturn') }); - $top->bind('' => sub { move('turn') }); - $top->bind('' => sub { move('left') }); - $top->bind('' => sub { move('right') }); - $top->bind('' => sub { move('turn') }); - foreach (qw/space KP_Enter/) { - $top->bind("<$_>" => sub { move('freefall') }); - } - $top->bind('

' => sub { toggle_pause() }); - $top->bind('' => \&stop_and_new_game); - $top->bind('' => \&help); - #$top->bind('all', '' => \&help); # don't pause - $top->bind('all', '' => \&lost); - #XXX Leave und Enter herausnehmen - $top->bind('' => sub { inc_pause(1) }); - # $top->bind('' => sub { inc_pause(1) }); - $top->bind('' => sub { dec_pause(1) }); - #$top->bind('' => sub { toggle_pause()}); - #$top->bind('' => sub { toggle_pause()}); - # $top->bind('' => sub { dec_pause(1) }); - } - - -sub inc_pause - { - my $quiet = shift; - $pause++; - if (!$quiet && !Tk::Exists($pause_w)) - { - my $width = $top->width; - my $height = $top->height; - $pause_w = $tetris->add('text',$pause_group, - -text => "PAUSE MODE :\n Type p to continue\n -\n\n\nHELP : \n\n- 'p' toggle pause\n\n- Arrow keys to move blocks\n\n- 'n' to start a new game\n\n ", - -font => $basefont->($fontheight), - -position => [30,50], - -anchor => 'nw', - - ); - } -} - -sub dec_pause - { - if ($pause) - { - $pause--; - if ($pause < 1) - { - $tetris->remove($pause_w); - undef $pause; - } - } - } - -sub toggle_pause - { - my $quiet = shift; - if ($pause) - { - $tetris->remove($pause_w);# if Tk::Exists($pause_w); - undef $pause; - } - else - { - - inc_pause($quiet); - } - } - - -sub action - { - if (!$pause) - { - if (!defined $active_block_nr) - { - if (!defined $next_block_nr) - { - get_next_block(); - } - $active_block_nr = $next_block_nr; - $blocks++; - $active_block = []; - copyblock($next_block, $active_block); - $active_dir = $next_dir; - get_next_block(); - } - if (defined $posx) - { - # erstes Zeichnen - if (testblock($active_block, $posx, $posy+1)) - { - drawblock($posx, $posy, 0); - $posy++; - drawblock($posx, $posy, 1); - } - else - { - array_update(($level+1) * int(($height-$posy+5)/5), - $posx, $posy); - return; - } - } - else - { - $posx = int($width / 2) - 1; - $posy = -$max_size; - } - } - $timer = $top->after($freefall ? 1 : speed(), \&action); - } - -sub get_next_block - { - $next_block_nr = int(rand()*$nmbr_blks); - $next_dir = int(rand()*4); - $next_block = $block->[$next_block_nr]; - for (0 .. $next_dir) - { - turn($next_block_nr, $next_block); - } - } - -sub turn - { - my($number, $block) = @_; - my($i, $j, $help_block); - if ($number != 6) - { - if ($number < 5) - { - for $i (1 .. $max_size-1) - { - for $j (0 .. $max_size-2) - { - $help_block->[$max_size-1-$j][$i-1] = $block->[$i][$j]; - } - } - for $i (1 .. $max_size-1) - { - for $j (0 .. $max_size-2) - { - $block->[$i][$j] = $help_block->[$i][$j]; - } - } - } - else - { - for $i (0 .. $max_size-1) - { - for $j (0 .. $max_size-1) - { - $help_block->[$max_size-1-$j][$i] = $block->[$i][$j]; - } - } - copyblock($help_block, $block); - } - } - } - -sub copyblock - { - my($from, $to) = @_; - die if ref $from ne 'ARRAY' || ref $to ne 'ARRAY'; - my($i, $j); - for $i (0 .. $max_size-1) - { - for $j (0 .. $max_size-1) - { - $to->[$i][$j] = $from->[$i][$j]; - } - } - } -sub rectangle - { - my($x, $y, $mode, $zinc) = @_; - $zinc->remove("$x-$y"); # Zinc command for deleting items - $zinc->remove("ombre$x-$y"); - if ($mode) - { - my($xx, $yy); - ($xx, $yy) = (($x-1)*$step_x, $y*$step_y); - my $color = $color_bright{$mode}; - # Adding new Zinc item : ball shadow - my $ombre=$zinc->add( - 'arc',$shadow_group,[$xx+10,$yy+10,$xx+$boxsize_x+10,$yy+$boxsize_y+10], - -visible=>1, - -filled=>1, - -fillcolor => $render ? "=path 50 50 |black;100 0|black;80 20|black;0 100" : "grey90", # color gradiant - -linewidth => 0, - -linecolor => 'yellow', - -priority => $render ? 6 : 10, - -tags => ["ombre$x-$y"]); - - $zinc->itemconfigure($shadow_group, -priority => 2); - - # Adding new Zinc item : ball - my $cercle=$zinc->add( - 'arc',$topgroup,[$xx,$yy,$xx+$boxsize_x,$yy+$boxsize_y], - -visible=>1, - -filled=>1, - -fillcolor => $render ? "=radial -20 -20 |white;90|$color;90" : $color, - -linewidth => 1, - -priority => 5, - -linecolor => "$color;80", - -tags => ["$x-$y"]); - } - } - -sub testblock - { - my($active_block, $posx, $posy) = @_; - for(my $i = 0; $i <= $max_size-1; $i++) - { - for(my $j = 0; $j <= $max_size-1; $j++) - { - if ($active_block->[$i][$j]) - { - if ($playfield->[$posy+$i][$posx+$j]) - { - return 0; - } - } - } - } - 1; - } - -sub drawblock - { - my($posx, $posy, $mode, $zinc) = @_; - my $y = $posy; - $zinc = $tetris if !$zinc; - for(my $i = 0; $i <= $max_size-1; $i++) - { - my $x = $posx; - for(my $j = 0; $j <= $max_size-1; $j++) - { - if ($active_block->[$i][$j]) - { - if (!$mode) - { - rectangle($x, $y, 0, $zinc); - } - else - { - rectangle($x, $y, $active_block->[$i][$j], $zinc); - } - } - $x++; - } - $y++; - } - } - - - -sub new_game { - reset_playfield(); - renew_field(); - reset_block(); - $next_block_nr = undef; - reset_game_param(); - action(); -} - -sub stop_and_new_game { - stop_game(); - new_game(), - } - -## no more used, because it quits zinc-demos -sub quit_game { - - print "Bye!\n"; - exit; -} - -sub lost { - $top->destroy; - print "You lost :o( !\n"; - exit; - } - -sub reset_game_param { - $points = $blocks = $lines = 0; - $level = level(); - $speed = speed(); - $pause = undef; -} - -sub stop_game { - undef_timer(); - undef $active_block; -} - -sub delete_line - { - my($y) = @_; - my $yy = $y*$step_y; - my $x; - for $x (1 .. $width-2) - { - my $xx = ($x-1)*$step_x; - $tetris->add - ('rectangle',1, - [$xx, $yy, $xx+$boxsize_x, $yy+$boxsize_y], - -filled => 1, - -fillcolor => 'orange;50', - -tags => ['delline'], - ); - } - $tetris->idletasks; - short_sleep(0.05); - $tetris->remove('delline'); - my $deuxpi = 3.1416; - my $i = 1; - my $angle = 360; - # special effect on TkZinc logo - rotation($deuxpi*$angle/360); - $mylines++; - $tetris->itemconfigure($new,-text => " $mylines Lines\n", -font => $basefont->($fontheight)); - } - -sub rotation - { - my ($angle, $cnt) = @_; - # first step of animation - if ($cnt == $stepsnumber) - { - inflation(); # scaling effect - return; - } - $cnt++; - # use 'rotation' Zinc method. - my $stepi = 360/$stepsnumber; - $angle = $stepi*2*3.1416/360; - $tetris->rotate($group, $angle, 250, 450 ); - # process the animation using the 'after' Tk defering method - $tetris->after($afterdelay, sub {rotation($angle, $cnt)}); - } - -sub inflation - { - my ($cnt) = @_; - my @pos = $tetris->coords($group); - my $zf; - # last step of animation - if ($cnt == 6) - { - return; - # event steps : wheel grows - } - elsif ($cnt % 2 == 0) - { - $zf = 4*$zoomrate; - # odd steps : wheel is shrunk - } - else - { - $zf = 1/(4*$zoomrate); - } - $cnt++; - # Now, we apply scale transformation to the Group item, using the 'scale' - # Zinc method. Note that we reset group coords before scaling it, in order - # that the origin of the transformation corresponds to the center of the - # wheel. When scale is done, we restore previous coords of group. - $tetris->coords($group, [0, 0]); - $tetris->scale($group, $zf, $zf); - $tetris->coords($group, \@pos); - # process the animation using the 'after' Tk defering method - $tetris->after(100, sub {inflation($cnt)}); - } - -sub game_over { - stop_game(); - # insert_highscore(); - # show_highscore('Game over'); - # save_highscore(); - #toggle_pause(); - my $width = $top->width; - my $height = $top->height; - my $new = $tetris->add('text',$pause_group, - -font => $basefont->($fontheight), - -text => "You lost ! :o)\ntype 'n' to try again !", - -position => [20,100], - ); - $top->update('idletasks'); - short_sleep(1); - $tetris->remove($new); - } - -sub move { - my($dir) = @_; - if (!$active_block || !defined $posx || $pause) { - $top->bell; - return; - } - if ($dir eq 'right' and testblock($active_block, $posx+1, $posy)) { - drawblock($posx, $posy, 0); - $posx++; - drawblock($posx, $posy, 1); - } elsif ($dir eq 'left' and testblock($active_block, $posx-1, $posy)) { - drawblock($posx, $posy, 0); - $posx--; - drawblock($posx, $posy, 1); - } elsif ($dir eq 'turn') { - my $help_block = []; - copyblock($active_block, $help_block); - turn($active_block_nr, $help_block); - if (testblock($help_block, $posx, $posy)) { - drawblock($posx, $posy, 0); - copyblock($help_block, $active_block); - drawblock($posx, $posy, 1); - } - } elsif ($dir eq 'antiturn') { - my $help_block = []; - copyblock($active_block, $help_block); - anti_turn($active_block_nr, $help_block); - if (testblock($help_block, $posx, $posy)) { - drawblock($posx, $posy, 0); - copyblock($help_block, $active_block); - drawblock($posx, $posy, 1); - } - } elsif ($dir eq 'freefall') { - if ($moveable_drop) { - $freefall = 1; - undef_timer(); - action(); - } else { - my $free_fall = 0; - while (testblock($active_block, $posx, $posy+1)) { - drawblock($posx, $posy, 0); - $posy++; - $free_fall++; - drawblock($posx, $posy, 1); - $top->idletasks; - } - array_update(($level+1)*int(($free_fall+$height-$posy+5)/5), - $posx, $posy); - } - } - } - -sub array_update - { - my($plus, $posx, $posy) = @_; - my($i, $j); - undef_timer(); - delete_shadow(); - for $i (0 .. $max_size-1) - { - for $j (0 .. $max_size-1) { - if ($active_block->[$i][$j] and $posy+$i >= 0) { - $playfield->[$posy+$i][$posx+$j] = $active_block->[$i][$j]; - } else { - if ($active_block->[$i][$j]) { - game_over(); - return; - } - } - } - } - $points += $plus; - - if ($posy >= 0) { - for $i ($posy .. $height-2) { - if (to_del_line($i)) { - delete_line($i); - $lines++; - $points += 10*($level+1); - for $j (reverse(0 .. $i-1)) { - my $k; - for $k (1 .. $width-2) { - $playfield->[$j+1][$k] = $playfield->[$j][$k]; - } - } - renew_field($i); - } - } - } - - my $oldlevel = $level; - $level = level(); - if ($oldlevel != $level) { - my $width = $top->width; - my $height = $top->height; - my $newlevel = $tetris->add('text',$pause_group, - -text => 'NEW LEVEL', - -font => $basefont->($fontheight), - -position => [20,20], - ); - $top->update('idletasks'); - short_sleep(0.5); - $tetris->remove($newlevel); - } - - reset_block(); - action(); -} - -sub anti_turn - { - my($number, $block) = @_; - for (1 .. 3) { turn($number, $block) } -} - -sub undef_timer { - if ($timer) { - $timer->cancel; - undef $timer; - } -} - -sub delete_shadow { - return if !$draw_shadow; - for(my $x = 1; $x <= $width-1; $x++) { -# rectangle($x, 0, 0, $shadow); - } -} - -sub to_del_line { - my($posy) = @_; - my $i; - - for $i (1 .. $width-2) { - if ($posy >= 0 and !$playfield->[$posy][$i]) { - return 0; - } - } - 1; -} -sub reset_block { - undef $active_block_nr; - undef $posx; - $freefall = 0; -} - -sub short_sleep { - my $sleep = shift; - if ($^O =~ /win/i) { - $top->Busy; - my $wait = 0; - $top->after($sleep*1000, sub { $wait = 1 }); - $top->waitVariable(\$wait); - $top->Unbusy; - } else { - eval { select(undef, undef, undef, $sleep) }; - } -} - -sub renew_field { - my($max_y) = @_; - $max_y = $height-2 if !defined $max_y; - my($i, $j); - for $i (0 .. $max_y) { - for $j (1 .. $width-2) { - if ($playfield->[$i][$j]) { - rectangle($j, $i, $playfield->[$i][$j], $tetris); - } else { - rectangle($j, $i, 0, $tetris); - } - } - } -} - -sub help - { - inc_pause(); - if (defined $help_top and Tk::Exists($help_top)) - { - $help_top->raise; - return; - } - require Tk::ROText; - my $firebutton = 'Button'; - eval { require Tk::FireButton; Tk::FireButton->VERSION(1.04); }; - $help_top = $top->Toplevel(-title => 'Tetris Help'); - make_key_bindings($help_top); - my $ti = "Zetris help :\n - truc 1\n - truc 2\n - truc 3\n \n"; - my $create_but = sub { - my($t, $command, $fire) = @_; - my $button = ($fire ? $firebutton : 'Button'); - my $but = $tetris->add('text',$pause_group, - -text => $ti, - -font => $base2font->(12), - -position => [20,20], - ); - }; - - my $cb = $help_top->Button(-text => 'Close', - -font => $base2font->(12), - -command => sub { $help_top->destroy })->pack; - $help_top->bind('' => sub { $cb->invoke }); -} diff --git a/Perl/demos/Tk/demos/zinc_lib/all_options.pl b/Perl/demos/Tk/demos/zinc_lib/all_options.pl deleted file mode 100644 index 25140f2..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/all_options.pl +++ /dev/null @@ -1,154 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# This simple demo has been developped by C. Mertz - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use Tk::Pane; - -use strict; - -my $mw = MainWindow->new(); - -# The explanation displayed when running this demo -my $label=$mw->Label(-text => -"Click on one of the following -buttons to get a list of Item -attributes (or zinc options) -with their types.\n", - -justify => 'left')->pack(-padx => 10, -pady => 10); - - -# Creating the zinc widget -my $zinc = $mw->Zinc(-width => 1, -height => 1, - -font => "10x20", # usually fonts are sets in resources - # but for this example it is set in the code! - -borderwidth => 0, -relief => 'sunken', - )->pack; - -# Creating an instance of every item type -my %itemtypes; - -# These Items have fields! So the number of fields must be given at creation time -foreach my $type qw(tabular track waypoint) { - $itemtypes{$type} = $zinc->add($type, 1, 0); -} - -# These items needs no specific initial values -foreach my $type qw(group icon map reticle text window) { - $itemtypes{$type} = $zinc->add($type, 1); -} - -# These items needs some coordinates at creation time -# However curves usually needs more than 2 points. -foreach my $type qw(arc curve rectangle) { - $itemtypes{$type} = $zinc->add($type, 1, [0,0 , 1,1]); -} -# Triangles item needs at least 3 points for the coordinates -foreach my $type qw(triangles) { - $itemtypes{$type} = $zinc->add($type, 1, [0,0 , 1,1 , 2,2]); -} - - -sub showAllOptions { - my ($type) = @_; - - my $tl = $mw->Toplevel; - my $title = "All options of an item $type"; - my @options; - if ($type eq 'zinc') { - @options = $zinc->configure(); - $title = "All options of zinc widget"; - } - else { - @options = $zinc->itemconfigure($itemtypes{$type}); - $title = "All attributes of an item $type"; - } - $tl->title($title); - my $frame = $tl->Scrolled('Pane', - -scrollbars => 'e', - -height => 600, - ); - $frame->pack(-padx => 10, -pady => 10, - -ipadx => 10, - -fill => 'both', - -expand => 1, - ); - - my $fm = $frame->LabFrame(-labelside => 'acrosstop', - -label => $title, - )->pack(-padx => 10, -pady => 10, - -ipadx => 10, - -fill => 'both'); - my $bgcolor = 'ivory'; - $fm->Label(-text => 'Option', -background => $bgcolor, -relief => 'ridge') - ->grid(-row => 1, -column => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => ($type eq 'zinc') ? 'optionClass' : 'Type', - -background => $bgcolor, -relief => 'ridge') - ->grid(-row => 1, -column => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => ($type eq 'zinc') ? 'defaultValue' : 'ReadOnly', - -background => $bgcolor, -relief => 'ridge') - ->grid(-row => 1, -column => 3, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - my $i = 2; - my %options; #we used this hastable to sort the options by their names - - if ($type eq 'zinc') { - for my $elem (@options) { -# print "$elem @$elem\n"; - my ($optionName, $optionDatabaseName, $optionClass, $default, $optionValue) = @$elem; - $options{$optionName} = [$optionClass, $default, "", $optionValue]; - } - } - else { - for my $elem (@options) { - my ($optionName, $optionType, $readOnly, $empty, $optionValue) = @$elem; - $options{$optionName} = [$optionType, $readOnly, $empty, $optionValue]; - } - } - for my $optionName (sort keys %options) { - my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$optionName}}; - $fm->Label(-text => $optionName, -relief => 'ridge') - ->grid(-row => $i, -column => 1, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - $fm->Label(-text => $optionType, -relief => 'ridge') - ->grid(-row => $i, -column => 2, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - - # $empty is for provision by Zinc - if ($type ne 'zinc') { - if ($readOnly) {$readOnly = "read only"} else { $readOnly = "" } - } - $fm->Label(-text => $readOnly, -relief => 'ridge') - ->grid(-row => $i, -column => 3, -ipady => 10, -ipadx => 5, -sticky => 'nswe'); - # we do not display $optionValue for these fake items - $i++; - } - $tl->Button(-text => 'Close', - -command => sub {$tl->destroy})->pack; - -} - -my $col = $mw->Frame()->pack(); - -my $width=0; -foreach my $type (sort keys %itemtypes) { - if (length ($type) > $width) { - $width = length ($type); - } -} - -foreach my $type (sort keys %itemtypes) { - $col->Button(-text => "$type", - -width => $width, - -command => sub {&showAllOptions ($type);}, - )->pack(-pady => 4); -} -$col->Button(-text => "zinc widget options", - -command => sub {&showAllOptions ('zinc');}, - )->pack(-pady => 4); - -MainLoop(); - - -1; diff --git a/Perl/demos/Tk/demos/zinc_lib/atomic-groups.pl b/Perl/demos/Tk/demos/zinc_lib/atomic-groups.pl deleted file mode 100644 index 67c019c..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/atomic-groups.pl +++ /dev/null @@ -1,221 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# this simple sample has been developped by C. Mertz mertz@cena.fr - -package atomic_groups; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use Tk::Checkbutton; -use Tk::Label; -use strict; - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); -my $zinc = $mw->Zinc(-width => 500, -height => 350, - -font => "10x20", # usually fonts are sets in resources - # but for this example it is set in the code! - -borderwidth => 0, - )->pack; - - -my $groups_group_atomicity = 0; -my $red_group_atomicity = 0; -my $green_group_atomicity = 0; - -my $display_clipping_item_background = 0; -my $clip = 1; - -$zinc->add('text', 1, - -font => $defaultfont, - -text => - "- There are 3 groups: a red group containing 2 redish objects,\n". - "a green group containing 2 greenish objects,\n". - "and groups_group containing both previous groups.\n". - "- You can make some groups atomic or not by depressing \n". - "the toggle buttons at the bottom of the window\n". - "- Try and then click on some items to observe that callbacks\n". - " are then different: they modify either the item, or 2 items of\n". - " a group or all items", - -anchor => 'nw', - -position => [10, 10]); - - -############### creating the top group with its bindings ############################### -my $groups_group = $zinc->add('group', 1, -visible => 1, - -atomic => $groups_group_atomicity, - -tags => [ 'groups_group' ]); - -# the following callbacks will be called only if 'groups_group' IS atomic -$zinc->bind($groups_group, '<1>', \&modify_bitmap_bg); -$zinc->bind($groups_group, '', \&modify_bitmap_bg); - -############### creating the red_group, with its binding and its content ################ -# the red_group may be atomic, that is is makes all children as a single object -# and sensitive to red_group callbacks -my $red_group = $zinc->add('group', $groups_group, - -visible => 1, - -atomic => $red_group_atomicity, - -sensitive => 1, - -tags => ['red_group'], - ); -# the following callbacks will be called only if 'groups_group' IS NOT-atomic -# and if 'red_group' IS atomic -$zinc->bind($red_group, '<1>', sub { &modify_item_lines($red_group)} ); -$zinc->bind($red_group, '', sub { &modify_item_lines($red_group)} ); - - -my $rc = $zinc->add('arc', $red_group, - [100, 200, 140, 240], - -filled => 1, -fillcolor => "red2", - -linewidth => 3, -linecolor => "white", - -tags => [ 'red_circle' ], - ); - -my $rr = $zinc->add('rectangle', $red_group, - [300, 200, 400,250], - -filled => 1, -fillcolor => "red2", - -linewidth => 3, -linecolor => "white", - -tags => [ 'red_rectangle' ], - ); -# the following callbacks will be called only if 'groups_group' IS NOT atomic -# and if 'red_group' IS NOT atomic -$zinc->bind($rc, '<1>', \&toggle_color); -$zinc->bind($rc, '', \&toggle_color); -$zinc->bind($rr, '<1>', \&toggle_color); -$zinc->bind($rr, '', \&toggle_color); - -############### creating the green_group, with its binding and its content ################ -# the green_group may be atomic, that is is makes all children as a single object -# and sensitive to green_group callbacks -my $green_group = $zinc->add('group', $groups_group, - -visible => 1, - -atomic => $green_group_atomicity, - -sensitive => 1, - -tags => ['green_group'], - ); -# the following callbacks will be called only if 'groups_group' IS NOT atomic -# and if 'green_group' IS atomic -$zinc->bind($green_group, '<1>', sub { &modify_item_lines($green_group) } ); -$zinc->bind($green_group, '', sub { &modify_item_lines($green_group) } ); - -my $gc = $zinc->add('arc', $green_group, - [100,270, 140,310], - -filled => 1, -fillcolor => "green2", - -linewidth => 3, -linecolor => "white", - -tags => [ 'green_circle' ], - ); - -my $gr = $zinc->add('rectangle', $green_group, - [300,270, 400,320], - -filled => 1, -fillcolor => "green2", - -linewidth => 3, -linecolor => "white", - -tags => [ 'green_rectangle' ], - ); -# the following callbacks will be called only if 'groups_group' IS NOT atomic -# and if 'green_group' IS NOT atomic -$zinc->bind($gc, '<1>', \&toggle_color); -$zinc->bind($gc, '', \&toggle_color); -$zinc->bind($gr, '<1>', \&toggle_color); -$zinc->bind($gr, '', \&toggle_color); - - - -my $current_bg = ''; -###################### groups_group callback ############## -sub modify_bitmap_bg { - if ($current_bg eq 'AlphaStipple2') { - $current_bg = ''; - } - else { - $current_bg = 'AlphaStipple2'; - } - foreach my $item ($rc, $rr, $gc, $gr) { - $zinc->itemconfigure($item, -fillpattern => $current_bg); - } -} - -#################### red/green_group callback ############## -sub modify_item_lines { - my ($gr) = @_; - my @children = $zinc->find('withtag', ".$gr*"); # we are using a pathtag (still undocumented feature of 3.2.6) to get items of an atomic group! - # we could also temporary modify the groups (make it un-atomic) to get its child - - my $current_linewidth = $zinc->itemcget($children[0], -linewidth); - if ($current_linewidth == 3) { - $current_linewidth = 0; - } - else { - $current_linewidth = 3; - } - foreach my $item (@children) { - $zinc->itemconfigure($item, -linewidth => $current_linewidth); - } - -} - - -##################### items callback ###################### -sub toggle_color { - my $item = $zinc->find('withtag', 'current'); - my $fillcolor = $zinc->itemcget($item, -fillcolor); - my ($color,$num) = $fillcolor =~ /([a-z]+)(\d)/ ; - if ($num == 2) { - $num = 4; - } - else { - $num = 2; - } - $zinc->itemconfigure($item, -fillcolor => "$color$num"); -} - - -###################### toggle buttons at the bottom ####### -my $row = $mw->Frame()->pack(); -$row->Checkbutton(-text => 'groups_group is atomic', - -variable => \$groups_group_atomicity, - -command => sub { &atomic_or_not ($groups_group, \$groups_group_atomicity) }, - )->pack(-anchor => 'w'); - -$row->Checkbutton(-text => 'red group is atomic ', - -foreground => "red4", - -variable => \$red_group_atomicity, - -command => sub { &atomic_or_not ($red_group, \$red_group_atomicity) }, - )->pack(-anchor => 'w'); - -$row->Checkbutton(-text => 'green group is atomic ', - -foreground => "green4", - -variable => \$green_group_atomicity, - -command => sub { &atomic_or_not ($green_group, \$green_group_atomicity) }, - )->pack(-anchor => 'w'); -$row->Label()->pack(-anchor => 'w'); -$row->Label(-text => "Following command \"\$zinc->find('overlapping', 0,200,500,400)\" returns:")->pack(-anchor => 'w'); -my $label = $row->Label(-background => 'gray95')->pack(-anchor => 'w'); - - -sub atomic_or_not { - my ($gr,$ref_atomic) = @_; - my $atomic = ${$ref_atomic}; - $zinc->itemconfigure( $gr, -atomic => $atomic); - &update_found_items; -} - -##### to update the list of enclosed items -sub update_found_items { - $zinc->update; # to be sure eveyrthing has been updated inside zinc! - my @found = $zinc->find('overlapping', 0,200,500,400); - my $str = ""; - foreach my $item (@found) { - my @tags = $zinc->itemcget($item, -tags); - $str .= " " . $tags[0]; - } - $label->configure (-text => $str); -} - -# to init the list of enclosed items -&update_found_items; - -Tk::MainLoop; diff --git a/Perl/demos/Tk/demos/zinc_lib/clipping.pl b/Perl/demos/Tk/demos/zinc_lib/clipping.pl deleted file mode 100644 index 4a320e0..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/clipping.pl +++ /dev/null @@ -1,150 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# this simple sample has been developped by C. Mertz mertz@cena.fr - -use Tk; -use Tk::Zinc; -use strict; -use Tk::Checkbutton; - -package clipping; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); -my $zinc = $mw->Zinc(-width => 700, -height => 600, - -font => "10x20", # usually fonts are sets in resources - # but for this example it is set in the code! - -borderwidth => 3, -relief => 'sunken', - )->pack; - -my $display_clipping_item_background = 0; -my $clip = 1; - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "You can drag and drop the objects.\n". - "There are two groups of objects, a \"tan group\" and a \"blue group\".\n". - "Try to move them and discover the clipping area which is a curve.\n". - "with two contours", - -anchor => 'nw', - -position => [10, 10]); - - -my $clipped_group = $zinc->add('group', 1, -visible => 1); - -my $clipping_item = $zinc->add('curve', $clipped_group, - [10,100, 690,100, 690,590, 520,350, - 350,590, 180,350, 10,590], - -closed => 1, - -priority => 1, - -fillcolor => "tan2", - -linewidth => 0, - -filled => $display_clipping_item_background); -$zinc->contour($clipping_item, "add", +1, [200,200, 500,200, 500,250, 200,250]); - -############### creating the tan_group objects ################ -# the tan_group is atomic, that is is makes all children as a single object -# and sensitive to tan_group callbacks -my $tan_group = $zinc->add('group', $clipped_group, - -visible => 1, - -atomic => 1, - -sensitive => 1, - ); - -$zinc->add('arc', $tan_group, - [200, 220, 280, 300], - -filled => 1, -linewidth => 1, - -startangle => 45, -extent => 270, - -pieslice => 1, -closed => 1, - -fillcolor => "tan", - ); - -$zinc->add('curve', $tan_group, - [400,400, 440,450, 400,500, 500,500, 460,450, 500,400], - -filled => 1, -fillcolor => "tan", - -linecolor => "tan", - ); - -############### creating the blue_group objects ################ -# the blue_group is atomic too, that is is makes all children as a single object -# and sensitive to blue_group callbacks -my $blue_group = $zinc->add('group', $clipped_group, - -visible => 1, - -atomic => 1, - -sensitive => 1, - ); - -$zinc->add('rectangle', $blue_group, - [570,180, 470,280], - -filled => 1, -linewidth => 1, - -fillcolor => "blue2", - ); - -$zinc->add('curve', $blue_group, - [200,400, 200,500, 300,500, 300,400, 300,300], - -filled => 1, -fillcolor => "blue", - -linewidth => 0, - ); - - -$zinc->itemconfigure($clipped_group, -clip => $clipping_item); - - -###################### drag and drop callbacks ############ -# for both tan_group and blue_group -$zinc->bind($tan_group, '' => [\&press, $tan_group, \&motion]); -$zinc->bind($tan_group, '' => \&release); -$zinc->bind($blue_group, '' => [\&press, $blue_group, \&motion]); -$zinc->bind($blue_group, '' => \&release); - -my ($x_orig, $y_orig); -sub press { - my ($zinc, $group, $action) = @_; - my $ev = $zinc->XEvent(); - $x_orig = $ev->x; - $y_orig = $ev->y; - $zinc->Tk::bind('', [$action, $group]); -} - -sub motion { - my ($zinc, $group) = @_; - my $ev = $zinc->XEvent(); - my $x = $ev->x; - my $y = $ev->y; - - $zinc->translate($group, $x-$x_orig, $y-$y_orig); - $x_orig = $x; - $y_orig = $y; -} - -sub release { - my ($zinc) = @_; - $zinc->Tk::bind('', ''); -} -###################### toggle buttons at the bottom ####### -my $row = $mw->Frame()->pack(); -$row->Checkbutton(-text => 'Show clipping item', - -variable => \$display_clipping_item_background, - -command => \&display_clipping_area)->pack; - -$row->Checkbutton(-text => 'Clip', - -variable => \$clip, - -command => \&clip)->pack; - -sub display_clipping_area { - $zinc->itemconfigure($clipping_item, -filled => $display_clipping_item_background); -} - -sub clip { - if ($clip) { - $zinc->itemconfigure($clipped_group, -clip => $clipping_item); - } - else { - $zinc->itemconfigure($clipped_group, -clip => undef); - } -} - -Tk::MainLoop; diff --git a/Perl/demos/Tk/demos/zinc_lib/color-circular.pl b/Perl/demos/Tk/demos/zinc_lib/color-circular.pl deleted file mode 100644 index 1ee1638..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/color-circular.pl +++ /dev/null @@ -1,75 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# these simple samples have been developped by C. Mertz mertz@cena.fr - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); -my $zinc = $mw->Zinc(-width => 700, -height => 600, - -borderwidth => 3, -relief => 'sunken', - -render => 1, # for activating the openGL render - )->pack; - -# This demo no more dies if there is no openGL. It simply displays -# a string on the bootom of the window! - - -$zinc->add('rectangle', 1, [10, 10, 80, 80], -fillcolor => "=radial 50 50 |red |blue", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "Radial variation from non-transparent red to non-transparent blue\nin a squarre. The gradient starts from the lower right corner.\n", - -anchor => 'nw', - -position => [120, 20]); - -$zinc->add('arc', 1, [10, 110, 90, 190], -fillcolor => "=radial 0 25 |red;40|blue;40", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "Radial variation from 40%transparent red to 40% transparent blue\nin a disc. The gradient starts in the middle between\nthe center on the bottom point", - -anchor => 'nw', - -position => [120, 120]); - -$zinc->add('arc', 1, [10, 210, 90, 290], -fillcolor => "=radial 0 0 |red;40|green;40 50|blue;40", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "A variation from 40%transparent red to 40% transparent blue.\n". - "through a 40%green on the middle of the disc. The gradient is centered.", - -anchor => 'nw', - -position => [120, 220]); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "Two overlaping radialy, transparently colored items on a white background", - -anchor => 'nw', - -position => [20, 320]); - -$zinc->add('rectangle', 1, [10, 340, 690, 590], -fillcolor => "white", -filled => 1); - -$zinc->add('rectangle', 1, [20, 365, 220, 565], -fillcolor => "=radial 0 0 |red;40|green;40 50|blue;40", -filled => 1); - -$zinc->add('arc', 1, [150, 365, 350, 565], -fillcolor => "=radial 0 0 |yellow;40|black;40 50|cyan;40", -filled => 1); - -$zinc->add('arc', 1, [280, 365, 480, 565], -fillcolor => "=radial 0 0 |black;100|black;100 20|white;40", -filled => 1, -linewidth => 0); - -$zinc->add('arc', 1, [480, 365, 580, 500], -fillcolor => "=radial -10 16 |black;100|white;40", -filled => 1); - -$zinc->add('arc', 1, [580, 410, 680, 580], -fillcolor => "=radial -40 -40 |black;70|white;20", -filled => 1); -$zinc->add('arc', 1, [580, 410, 680, 580], -fillcolor => "=radial 40 40 |black;70|white;20", -filled => 1); - - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "WITHOUT openGL, NO GRADIENT. SORRY!", - -anchor => 'nw', - -position => [20, 550]) unless $zinc->cget(-render); - -MainLoop; - diff --git a/Perl/demos/Tk/demos/zinc_lib/color-path-and-conic.pl b/Perl/demos/Tk/demos/zinc_lib/color-path-and-conic.pl deleted file mode 100644 index 264811f..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/color-path-and-conic.pl +++ /dev/null @@ -1,78 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# these simple samples have been developped by C. Mertz mertz@cena.fr - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); -my $zinc = $mw->Zinc(-width => 700, -height => 600, - -borderwidth => 3, -relief => 'sunken', - -render => 1, # for activating the openGL render - )->pack; - -# This demo no more dies if there is no openGL. It simply displays -# a string on the bootom of the window! - - -$zinc->add('rectangle', 1, [10, 10, 80, 80], -fillcolor => "=path 0 0 |red |blue", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "Path variation from non-transparent red to non-transparent blue\nin a squarre. The gradient start at the middle of the bbox.", - -anchor => 'nw', - -position => [120, 20]); - -$zinc->add('arc', 1, [10, 110, 90, 190], -fillcolor => "=conical 135 |black;40|white;40", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "Conical variation from 40%transparent black to 40% transparent white\nin a disc, center in the middle of the bbox", - -anchor => 'nw', - -position => [120, 120]); - - -$zinc->add('arc', 1, [10, 210, 90, 290], -fillcolor => "=path -30 +30 |red;40|green;40 50|blue;40", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "A path variation from 40%transparent red to 40% transparent blue.\n". - "through a 40%green on the middle of the disc. The gradient center\nis toward the SW of the bbox.", - -anchor => 'nw', - -position => [120, 220]); - - - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "overlaping path and conical, transparently colored items on a white background", - -anchor => 'nw', - -position => [20, 320]); - -$zinc->add('rectangle', 1, [10, 340, 690, 590], -fillcolor => "white", -filled => 1); - -$zinc->add('rectangle', 1, [20, 365, 220, 565], -fillcolor => "=path -40 -40 |red;40|green;40 50|blue;40", -filled => 1); - -$zinc->add('arc', 1, [150, 365, 350, 565], -fillcolor => "=conical 20 -30 45 |yellow;40|black;40 50|cyan;40", -filled => 1); - -$zinc->add('arc', 1, [320, 365, 480, 565], -fillcolor => "=path 0 0 |black;100|black;100 20|white;40", -filled => 1, -linewidth => 0); - -#$zinc->add('arc', 1, [480, 365, 580, 500], -fillcolor => "=radial -10 16 |black;100|white;40", -filled => 1); - -$zinc->add('arc', 1, [580, 410, 680, 580], -fillcolor => "=conical -40 -40 135 |black;70|white;20", -filled => 1); -#$zinc->add('arc', 1, [580, 410, 680, 580], -fillcolor => "=radial 40 40 |black;70|white;20", -filled => 1); - - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "WITHOUT openGL, NO GRADIENT. SORRY!", - -anchor => 'nw', - -position => [20, 550]) unless $zinc->cget(-render); - -MainLoop; - diff --git a/Perl/demos/Tk/demos/zinc_lib/color-x.pl b/Perl/demos/Tk/demos/zinc_lib/color-x.pl deleted file mode 100644 index 62937b2..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/color-x.pl +++ /dev/null @@ -1,94 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# these simple samples have been developped by C. Mertz mertz@cena.fr - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); -my $zinc = $mw->Zinc(-width => 700, -height => 600, - -borderwidth => 3, -relief => 'sunken', - -render => 1, # for activating the openGL render - )->pack; - -# This demo no more dies if there is no openGL. It simply displays -# a string on the bootom of the window! - -$zinc->add('rectangle', 1, [10,10, 690, 50], -fillcolor => "=axial 0 | red | blue", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "A variation from non transparent red to non transparent blue.", - -anchor => 'nw', - -position => [20, 20]); - - -$zinc->add('rectangle', 1, [10,60, 690, 100], -fillcolor => "=axial -30 0 30 0 | red | blue", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "The same with a reduced span.", - -anchor => 'nw', - -position => [20, 70]); - - -$zinc->add('rectangle', 1, [10,110, 690, 150], -fillcolor => "=axial 0 |red;40|blue;40", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "A variation from 40%transparent red to 40% transparent blue.", - -anchor => 'nw', - -position => [20, 120]); - - -$zinc->add('rectangle', 1, [10,160, 690, 200], -fillcolor => "=axial -30 0 30 0 |red;40|blue;40", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "The same with a reduced span.", - -anchor => 'nw', - -position => [20, 170]); - - -# we are using here the X explicit notation for rgb color -# we could also have used CIE encoding. If interested, -# please read the X man pages -my $gradient = ($^O eq 'linux') ? "=axial 0 | rgb:ffff/0/0;40 | rgb:0/ffff/0;40 50 | rgb:0/0/ffff;40" - : "=axial 0 | #ff0000;40 | #00ff00;40 50 | #0000ff;40"; - -$zinc->add('rectangle', 1, [10, 210, 690, 300], -fillcolor => "=axial 0 | rgb:ffff/0/0;40 | rgb:0/ffff/0;40 50 | rgb:0/0/ffff;40", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "A variation from 40%transparent red to 40% transparent blue.\n". - "through a 40%green on the middle", - -anchor => 'nw', - -position => [20, 220]); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "Two overlaping transparently colored rectangles on a white background", - -anchor => 'nw', - -position => [20, 320]); - -$zinc->add('rectangle', 1, [10, 340, 690, 590], -fillcolor => "white", -filled => 1); -$zinc->add('rectangle', 1, [200, 350, 500, 580], -fillcolor => "red;40|green;40 50|blue;40", -filled => 1); - -$zinc->add('rectangle', 1, [10, 400, 690, 500], -fillcolor => "=axial 0 |yellow;40|black;40 50|cyan;40", -filled => 1); - - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "WITHOUT openGL, NO GRADIENT. SORRY!", - -anchor => 'nw', - -position => [20, 550]) unless $zinc->cget(-render); - - - -MainLoop; - diff --git a/Perl/demos/Tk/demos/zinc_lib/color-y.pl b/Perl/demos/Tk/demos/zinc_lib/color-y.pl deleted file mode 100644 index b33f269..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/color-y.pl +++ /dev/null @@ -1,91 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# these simple samples have been developped by C. Mertz mertz@cena.fr - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); -my $zinc = $mw->Zinc(-width => 700, -height => 600, - -borderwidth => 3, -relief => 'sunken', - -render => 1, # for activating the openGL render - )->pack; - -# This demo no more dies if there is no openGL. It simply displays -# a string on the bootom of the window! - - -$zinc->add('rectangle', 1, [10, 10, 340, 100], -fillcolor => "=axial 90 |red |blue", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "A variation from non transparent red\n to non transparent blue.", - -anchor => 'nw', - -position => [20, 20]); - - -$zinc->add('rectangle', 1, [360, 10, 690, 100], -fillcolor => "=axial 0 30 0 -30 |red |blue", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "The same with a reduced span.", - -anchor => 'nw', - -position => [370, 20]); - - - -$zinc->add('rectangle', 1, [10,110, 330, 200], -fillcolor => "=axial 90|red;40 |blue;40", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "A variation from 40%transparent red\nto 40% transparent blue.", - -anchor => 'nw', - -position => [20, 120]); - - -$zinc->add('rectangle', 1, [360,110, 690, 200], -fillcolor => "=axial 0 30 0 -30|red;40 |blue;40", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "The same with a reduced span.", - -anchor => 'nw', - -position => [370, 120]); - - -$zinc->add('rectangle', 1, [10, 210, 690, 300], -fillcolor => "=axial 90 |red;40|green;40 50|blue;40", -filled => 1); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "A variation from 40%transparent red to 40% transparent blue.\n". - "through a 40%green on the middle", - -anchor => 'nw', - -position => [20, 220]); - - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "Two overlaping transparently colored rectangles on a white background", - -anchor => 'nw', - -position => [20, 320]); - -$zinc->add('rectangle', 1, [10, 340, 690, 590], -fillcolor => "white", -filled => 1); -$zinc->add('rectangle', 1, [200, 350, 500, 580], -fillcolor => "=axial 90 |red;40|green;40 50|blue;40", -filled => 1); - -$zinc->add('rectangle', 1, [10, 400, 690, 500], -fillcolor => "=axial 90 |yellow;40|black;40 50|cyan;40", -filled => 1); - - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "WITHOUT openGL, NO GRADIENT. SORRY!", - -anchor => 'nw', - -position => [20, 550]) unless $zinc->cget(-render); - - - -MainLoop; - diff --git a/Perl/demos/Tk/demos/zinc_lib/contours.pl b/Perl/demos/Tk/demos/zinc_lib/contours.pl deleted file mode 100644 index db0b960..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/contours.pl +++ /dev/null @@ -1,202 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# This simple demo has been developped by C. Mertz - -package contours; # for avoiding symbol collision between different demos - -use Tk; -use Tk::Zinc; - -use strict; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -my $mw = MainWindow->new(); - -# The explanation displayed when running this demo -my $text = $mw->Text(-relief => 'sunken', -borderwidth => 2, - -setgrid => 'true', -height => 9); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', -'All visibles items are made by combining 2 items using contours: - - the firebrick curve1 has been holed using a addhole with a circle, - - the lightblue curve2 has been "mickey-moused" by adding two circles, - - the yellow curve3 is the union with a disjoint circle, - - the grey curve4 is combined with 7 circles, with \'positive\' -fillrule. -The following operations are possible: - - "Mouse Button 1" for dragging objects. - - "Mouse Button 1" for dragging the black handle and - modifying the grey curve contour.'); - -# Creating the zinc widget -my $zinc = $mw->Zinc(-width => 600, -height => 500, - -font => "10x20", # usually fonts are sets in resources - # but for this example it is set in the code! - -borderwidth => 3, -relief => 'sunken', - )->pack; - - -# Creation of 2 items NOT visible, but used for creating visible -# curves[1-5] with more than one contours. -# The center of these 2 items is 200,100 -my $curve0 = $zinc->add('curve', 1, [ [300,0], [400,100, 'c'], [300,200], [200,300,'c'], [100,200], [0,100,'c'], [100,0], ], - -closed => 1, -visible => 0, -filled => 1, - ); -my $cercle100 = $zinc->add('arc', 1, [130,30, 280,180], - -visible => 0, - ); - -# cloning curve0 as curve1 and moving it -my $curve1 = $zinc->clone($curve0, -visible => 1, -fillcolor => "firebrick1"); -# adding a 'difference' contour to the curve1 -$zinc->contour($curve1, 'add', +1, $cercle100); - - -# cloning curve0 as curve2 and moving it -# creating a curve without contour to control contour clockwise/counterclockwise -my $curve2 = $zinc->add('curve', 1, [], -closed => 1, -filled => 1, - -visible => 1, -fillcolor => "lightblue2", -fillrule => 'positive'); -$zinc->contour($curve2, 'add', -1, $curve0); ## why must the flag be -1 and not -1 !? -# adding the left ear of mickey mouse! -$zinc->translate($curve2,100,90); -# adding the right ear of mickey mouse! -$zinc->contour($curve2, 'add', +1, $cercle100); - -$zinc->translate($curve2,-200,0); -# adding an 'intersection' contour to the curve2 -$zinc->contour($curve2, 'add', +1, $cercle100); - -# ... translate to make it more visible -$zinc->translate($curve2, 320,20); - - -# cloning curve0 as curve3 and moving it -my $curve3 = $zinc->clone($curve0, -visible => 1, -fillcolor => "yellow3"); -$zinc->translate($curve3,0,290); -# adding an 'union' contour to the curve3 -$zinc->contour($curve3, 'add', +1, $cercle100); -# ... translate to make it more visible -$zinc->translate($curve3, -130,00); - - - - -# cloning curve0 as curve4 and moving it slightly -my $curve4 = $zinc->clone($curve0, -visible => 1, -fillcolor => "grey50", - -tags => ["grouped"], - -fillrule => 'positive', - # the tag "grouped" is used for both curve4 and - # a handle (see just below) - # It is used for translating both easily - ); - -my $index = 2; ## index of the vertex associated to the handle -my ($x,$y) = $zinc->coords($curve4,0,$index); -my $handle = $zinc->add('rectangle', 1, [$x-5,$y-5,$x+5,$y+5], - -fillcolor => 'black', -filled => 1, - -tags => ["grouped"], - ); - -# adding a 'difference' contour to the curve4 -$zinc->contour($curve4, 'add', +1, $cercle100); -$zinc->translate('grouped',110,0); -$zinc->contour($curve4, 'add', +1, $cercle100); -$zinc->translate('grouped',-220,0); -$zinc->contour($curve4, 'add', +1, $cercle100); -$zinc->translate('grouped',110,80); -$zinc->contour($curve4, 'add', -1, $cercle100); -$zinc->translate('grouped',0,-160); -$zinc->contour($curve4, 'add', +1, $cercle100); - -$zinc->translate('grouped',200,80); -$zinc->contour($curve4, 'add', +1, $cercle100); -$zinc->translate('grouped',-350,0); -$zinc->contour($curve4, 'add', +1, $cercle100); - -$zinc->translate('grouped',350,250); -#$zinc->lower('grouped'); - -# Deleting no more usefull items: curve0 and cercle100: -$zinc->remove($curve0, $cercle100); - -$zinc->raise($curve1); - -# adding drag and drop callback to each visible curve! -foreach my $item ($curve1, $curve2, $curve3, $curve4) { - # Some bindings for dragging the items - $zinc->bind($item, '' => [\&press, $item, \&motion]); - $zinc->bind($item, '' => \&release); -} - -# adding drag and drop on curve4 which also moves handle -$zinc->bind($curve4, '' => [\&press, $curve4, \&motionWithHandle]); -$zinc->bind($curve4, '' => \&release); - -# adding drag and drop on handle which also modify curve4 -$zinc->bind($handle, '' => [\&press, $handle, \&moveHandle]); -$zinc->bind($handle, '' => \&release); - -# callback for starting a drag -my ($x_orig, $y_orig); -sub press { - my ($zinc, $item, $action) = @_; - my $ev = $zinc->XEvent(); - $x_orig = $ev->x; - $y_orig = $ev->y; - $zinc->Tk::bind('', [$action, $item]); -} - -# Callback for moving an item -sub motion { - my ($zinc, $item) = @_; - my $ev = $zinc->XEvent(); - my $x = $ev->x; - my $y = $ev->y; - - $zinc->translate($item, $x-$x_orig, $y-$y_orig); - $x_orig = $x; - $y_orig = $y; -} - -# Callback for moving an item and its handle -sub motionWithHandle { - my ($zinc, $item) = @_; - my $ev = $zinc->XEvent(); - my $x = $ev->x; - my $y = $ev->y; - - my ($tag) = $zinc->itemcget($item, -tags); - $zinc->translate($tag, $x-$x_orig, $y-$y_orig); - $x_orig = $x; - $y_orig = $y; -} - -# Callback for moving the handle and modifying curve4 -# this code is far from being generic. Only for demonstrating how we can -# modify a contour with a unique handle! -sub moveHandle { - my ($zinc, $handle) = @_; - my $ev = $zinc->XEvent(); - my $x = $ev->x; - my $y = $ev->y; - - $zinc->translate($handle, $x-$x_orig, $y-$y_orig); - - my ($vertxX,$vertxY) = $zinc->coords($curve4,0,$index); - $zinc->coords($curve4,0,$index, [$vertxX+($x-$x_orig), $vertxY+($y-$y_orig)]); - $x_orig = $x; - $y_orig = $y; -} - -# Callback when releasing the mouse button. It removes any motion callback -sub release { - my ($zinc) = @_; - $zinc->Tk::bind('', ''); -} - -Tk::MainLoop(); - - -1; diff --git a/Perl/demos/Tk/demos/zinc_lib/counter.pl b/Perl/demos/Tk/demos/zinc_lib/counter.pl deleted file mode 100644 index a0e9534..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/counter.pl +++ /dev/null @@ -1,440 +0,0 @@ -#!/usr/bin/perl -# This simple demo has been developped by C. Schlienger - -package counter; # for avoiding symbol collision between different demos - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; -use constant; - -my constant $PI=3.1416; - -my $boldfont = '-adobe-helvetica-bold-r-normal--20-240-100-100-p-182-iso8859-1'; - -my $mw = MainWindow->new(); - -################################################### -# Zinc -################################################### - -my $zinc = $mw->Zinc(-width => 700, -height => 400, - -font => "10x20", - -borderwidth => 3, - -relief => 'sunken', - -render => 1, - )->pack; - -if ($zinc->cget(-render)) { - $zinc->add('rectangle', 1, - [0,0,700,400], - -filled => 1, -linewidth => 0, - -fillcolor => "=axial 90 |red;40|green;40 50|blue;40" - ); -} else { ## no openGL rendering! - # creating a curve in the background to demonstrate the clipping - # of the hole in the counter - $zinc->add('curve', 1, [30,30, 350,150, 670,30, 400,200, 670,370, 350,250, 30,370, 300,200, 30,30], - -filled => 1, - -fillcolor => "tan", - ); -} - -# The explanation displayed when running this demo -$zinc->add('text', 1, - -position=> [10,10], - -text => 'This toy-appli shows a simple counter. It is made thanks -to clipping and contours : this is the only way to do this. -You can drag the counter. Observe that the color of the background -of the counter is the same as the one of the window (use of clips)', - -font => "10x20", - ); - -################################################### -# Les positions -################################################### - -#-------------------------------- -# Carre dans lequel sera inscrit le cercle du compteur -#--------------------------------- - -my $x0=250; -my $y0=100; -my $x1=$x0+200; -my $y1=$y0+200; - -#-------------------------------- -# Rectangle dans lequel defileront les chiffres -#--------------------------------- - -my $x2=$x0+50; -my $y2=$y0+130; -my $x3=$x1-50; -my $y3=$y1-50; - - -################################################### -# Chiffres clippes -################################################### - -my $general_group = $zinc->add('group',1, -visible => 1); - -my $clipped_group1 = $zinc->add('group',$general_group, -visible => 1); - -#-------------------------------- -# Clipping items -#--------------------------------- - -my $clipping_item1 = $zinc->add('curve', $clipped_group1, - [$x2,$y2,$x3,$y2,$x3,$y3,$x2,$y3,$x2,$y2] - ); - -#-------------------------------- -# Clipped items -#--------------------------------- - -my $group1=$zinc->add('group',$clipped_group1); - -my $ecart=17; - -# Il y a deux listes de chifres pour centaines, dizaines, unites, -# pour assurer l'enchainement des chiffres quand le temps passe -# (cf. : actions automatiques) - -#-------------------------------- -# Centaines -#--------------------------------- - -my $cent = $zinc->add('group',$group1, -visible => 1,); -my $xc=$x2+20; -my $yc=$y2; - - -my $nbc1=$zinc->add('text', $cent, - -font => $boldfont, - -text => "0 -1 -2 -3 -4 -5 -6 -7 -8 -9", - -anchor => 'nw', - -position => [$xc, $yc], -); -my $nbc2=$zinc->add('text', $cent, - -font => $boldfont, - -text => "0 -1 -2 -3 -4 -5 -6 -7 -8 -9", - -anchor => 'nw', - -position => [$xc, $yc+210], -); -#-------------------------------- -# Dixaines -#--------------------------------- - -my $dix = $zinc->add('group',$group1, -visible => 1); - -my $xd=$xc+30; -my $yd=$y2; -my $nbd1=$zinc->add('text', $dix, - -font => $boldfont, - -text => "0 -1 -2 -3 -4 -5 -6 -7 -8 -9", - -anchor => 'nw', - -position => [$xd,$yd]); - -my $nbd2=$zinc->add('text', $dix, - -font => $boldfont, - -text => "0 -1 -2 -3 -4 -5 -6 -7 -8 -9", - -anchor => 'nw', - -position => [$xd,$yd+210]); -#-------------------------------- -# Unites -#--------------------------------- - -my $unit = $zinc->add('group',$group1, -visible => 1); -my $xu=$xd+30; -my $yu=$y2; -my $nbu1=$zinc->add('text', $unit, - -font => $boldfont, - -text => "0 -1 -2 -3 -4 -5 -6 -7 -8 -9", - -anchor => 'nw', - -position => [$xu, $yu]); - -my $nbu2=$zinc->add('text', $unit, - -font => $boldfont, - -text => "0 -1 -2 -3 -4 -5 -6 -7 -8 -9", - -anchor => 'nw', - -position => [$xu, $yu+210]); - -#-------------------------------- -# Clip -#--------------------------------- - -$zinc->itemconfigure($clipped_group1, -clip => $clipping_item1); - - -################################################### -# Cadran clippe -################################################### - -my $clipped_group2 = $zinc->add('group',$general_group, -visible => 1); - -#-------------------------------- -# Clipping items -#--------------------------------- - -my $clipping_item2 = $zinc->add('curve', $clipped_group2, - [0,0,700,0,700,700,0,700,0,0], - -linewidth=>0, - ); - -$zinc->contour($clipping_item2,"add",0,[$x2,$y2,$x3,$y2,$x3,$y3,$x2,$y3,$x2,$y2]); - -#-------------------------------- -# Clipped items -#--------------------------------- - -my $group2=$zinc->add('group',$clipped_group2); - -my $cercle=$zinc->add('arc',$group2,[$x0,$y0,$x1,$y1], - -visible=>1, - -filled=>1, - -fillcolor=>"yellow",); - -my $fleche=$zinc-> add('curve', $group2, [$x0+40,$y0+40,$x1-100,$y1-25], - -firstend => [10, 10, 10], - -linewidth => 7, - -linecolor=>"red", - ); - -#-------------------------------- -# Clip -#--------------------------------- - -$zinc->itemconfigure($clipped_group2, -clip => $clipping_item2); - -# this translation if for having an "interesting" background in the counter hole -# when we do not have openGL and a gradient in the background -$zinc->translate($general_group,0,21); - -################################################### -# Actions automatiques -################################################### - -#-------------------------------- -# Variables -#--------------------------------- -# Pour le timer -my $repeat=10; - -# Pour la rotation -my @centre=($x1-100,$y1-25); -my $pas=40; -my $angle=+$PI/$pas; -my $nb_tot=12; -my $nb=0; - -# Pour la translation des centaines -my @c_c1=$zinc->itemcget($nbc1,-position); -my @c_c2=$zinc->itemcget($nbc2,-position); -my $nbtour_cent=2; - -# Pour la translation des dizaines -my @c_d1=$zinc->itemcget($nbd1,-position); -my @c_d2=$zinc->itemcget($nbd2,-position); -my $nbtour_dix=2; - -# Pour la translation des unites -my @c_u1=$zinc->itemcget($nbu1,-position); -my @c_u2=$zinc->itemcget($nbu2,-position); -my $nbtour_unit=2; - - -#-------------------------------- -# Timer -#--------------------------------- -my $timer = $zinc->repeat($repeat, [\&refresh]); - -$mw->OnDestroy(\&destroyTimersub ); - -my $timerIsDead = 0; -sub destroyTimersub { - $timerIsDead = 1; - $mw->afterCancel($timer); - # the timer is not really cancelled when using zinc-demos! -} - -#-------------------------------- -# Actions -#--------------------------------- -sub refresh { - #-------------------------------- - # Rotation de la fleche - #--------------------------------- - return if $timerIsDead; # the timer is still running when using zinc-demos! - $zinc->rotate($fleche,$angle,$centre[0],$centre[1]); - $nb+=1; - if (($nb==$nb_tot)&&($angle==$PI/$pas)) - { - $nb=0; - $angle=-$PI/$pas; - } - else{ - if(($nb==$nb_tot)&&($angle==-$PI/$pas)){ - $nb=0; - $angle=+$PI/$pas; - } - } - #-------------------------------- - # Deplacement du texte - #--------------------------------- - - #-------------------------------- - # Centaines - #--------------------------------- - $zinc->translate($cent,0,-0.01); - - my @coords_c1=$zinc->transform($cent,$group1,[$c_c1[0],$c_c1[1]]); - if(int($coords_c1[1])==$yc-210){ - $zinc->itemconfigure($nbc1,-position=>[$xc,$yc+($nbtour_cent*210)]); - $nbtour_cent+=1; - @c_c1=$zinc->itemcget($nbc1,-position); - } - - my @coords_c2=$zinc->transform($cent,$group1,[$c_c2[0],$c_c2[1]]); - if($coords_c2[1]==$yc-210){ - $zinc->itemconfigure($nbc2,-position=>[$xc,$yc+($nbtour_cent*210)]); - $nbtour_cent+=1; - @c_c2=$zinc->itemcget($nbc2,-position); - } - - #-------------------------------- - #Dixaines - #--------------------------------- - $zinc->translate($dix,0,-0.1); - - my @coords_d1=$zinc->transform($dix,$group1,[$c_d1[0],$c_d1[1]]); - if(int($coords_d1[1])==$yd-210){ - $zinc->itemconfigure($nbd1,-position=>[$xd,$yd+($nbtour_dix*210)]); - $nbtour_dix+=1; - @c_d1=$zinc->itemcget($nbd1,-position); - } - - my @coords_d2=$zinc->transform($dix,$group1,[$c_d2[0],$c_d2[1]]); - if($coords_d2[1]==$yd-210){ - $zinc->itemconfigure($nbd2,-position=>[$xd,$yd+($nbtour_dix*210)]); - $nbtour_dix+=1; - @c_d2=$zinc->itemcget($nbd2,-position); - } - - - #-------------------------------- - # Unites - #--------------------------------- - $zinc->translate($unit,0,-1); - - my @coords_u1=$zinc->transform($unit,$group1,[$c_u1[0],$c_u1[1]]); - if($coords_u1[1]==$yu-210){ - $zinc->itemconfigure($nbu1,-position=>[$xu,$yu+($nbtour_unit*210)]); - $nbtour_unit+=1; - @c_u1=$zinc->itemcget($nbu1,-position); - } - - my @coords_u2=$zinc->transform($unit,$group1,[$c_u2[0],$c_u2[1]]); - if($coords_u2[1]==$yu-210){ - $zinc->itemconfigure($nbu2,-position=>[$xu,$yu+($nbtour_unit*210)]); - $nbtour_unit+=1; - @c_u2=$zinc->itemcget($nbu2,-position); - } - -} - -################################################### -# Actions manuelles -################################################### - -#--------------------------------------------- -# Drag and drop the counter -#--------------------------------------------- - -my ($prev_x, $prev_y); -$zinc -> bind($cercle,''=>[\&move_on] ); - - -#"move_on" state# -sub move_on{ - $prev_x=$zinc->XEvent()->x; - $prev_y=$zinc->XEvent()->y; - # move the counter - $zinc -> bind($cercle,''=> [\&move]); - $zinc -> bind($cercle,''=> [\&move_off]); #"move_off" state -} - - -#"move_off" state# -sub move_off{ - $zinc -> bind($cercle,''=>""); - $zinc -> bind($cercle,''=>""); -} - -#move the counter# -sub move{ - my $x=$zinc->XEvent()->x, - my $y=$zinc->XEvent()->y; - $zinc->translate($clipped_group1,$x-$prev_x,$y-$prev_y); - $zinc->translate($clipped_group2,$x-$prev_x,$y-$prev_y); - ($prev_x,$prev_y) = ($x,$y); -} - -Tk::MainLoop; diff --git a/Perl/demos/Tk/demos/zinc_lib/curve_bezier.pl b/Perl/demos/Tk/demos/zinc_lib/curve_bezier.pl deleted file mode 100644 index bc59863..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/curve_bezier.pl +++ /dev/null @@ -1,221 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# This simple demo has been developped by C. Mertz - -####### This file has been initially inspired from svg examples - -package curveBezier; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk::Zinc; - - -my $mw = MainWindow->new(); -$mw->title('example of curves with cubic control points'); - -my $text = $mw->Text (-relief => 'sunken', -borderwidth => 2, - -setgrid => 'true', -height =>3); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', -'6 examples of curves containing control points are displayed, - with the list of control points written just below. -You can move the handles to modify the bezier curves'); - - -my $zinc = $mw->Zinc(-width => 700, -height => 650, - -font => "10x20", - -font => "9x15", - -borderwidth => 0, - -backcolor => "white", - -forecolor => "grey80", - -render => 1, # this demo also works without openGL - # with openGL, antialiasing makes the curves nicer - )->pack; - -my $group = $zinc->add('group', 1); - -$zinc->add('text',$group, -position => [50,20], -anchor => 'w', - -text => "Examples of curve items using cubic bezier control points", - -color => "grey20"); - -## Please note: much of the following items below could be computed -$zinc->add('text',$group, -position => [25,270], -anchor => 'w', -tags => ['bezier1'], -color => "grey20"); -$zinc->add('curve',$group,[100, 200, 100, 100], -tags => ['line1', 'l1-2'], -linecolor => "#888888", -filled => 0, -linewidth => 2); -$zinc->add('curve',$group,[400, 100, 400, 200], -tags => ['line1', 'l3-4'], -linecolor => "#888888", -filled => 0, -linewidth => 2); -$zinc->add('curve',$group,[[100, 200], [100, 100, 'c'], [400, 100, 'c'], [400, 200]], - -tags => ['bezier1'], -closed => 0, -linecolor => "red", -linewidth => 5); -$zinc->add('arc',$group,[90, 190, 110, 210], -tags => ['handle1',"p1"], -filled => 1, -fillcolor => "#BBBBBB"); -$zinc->add('arc',$group,[90, 90, 110, 110], -tags => ['handle1',"p2"], -filled => 1, -linewidth => 0, -fillcolor => "grey80", -filled => 1); -$zinc->add('arc',$group,[390, 90, 410, 110], -tags => ['handle1',"p3"], -filled => 1, -linewidth => 0, -fillcolor => "grey80", -filled => 1); -$zinc->add('arc',$group,[390, 190, 410, 210], -tags => ['handle1',"p4"], -filled => 1, -fillcolor => "#BBBBBB"); - -$zinc->add('text',$group, -position => [570,270], -anchor => 'w', -tags => ['bezier2'], -color => "grey20"); -$zinc->add('curve',$group,[600, 200, 675, 100], -tags => ['line2', 'l1-2'], -linecolor => "#888888", -linewidth => 2); -$zinc->add('curve',$group,[975, 100, 900, 200], -tags => ['line2', 'l3-4'], -linecolor => "#888888", -linewidth => 2); -$zinc->add('curve',$group,[[600, 200], [675, 100, 'c'], [975, 100, 'c'], [900, 200]], - -tags => ['bezier2'], -closed => 0, -linecolor => "red", -linewidth => 5); -$zinc->add('arc',$group,[590, 190, 610, 210], -tags => ['handle2',"p1"], -filled => 1, -linecolor => "grey80", -linewidth => 2); -$zinc->add('arc',$group,[665, 90, 685, 110], -tags => ['handle2',"p2"], -filled => 1, -linewidth => 0, -fillcolor => "grey80"); -$zinc->add('arc',$group,[965, 90, 985, 110], -tags => ['handle2',"p3"], -filled => 1, -linewidth => 0, -fillcolor => "grey80"); -$zinc->add('arc',$group,[890, 190, 910, 210], -tags => ['handle2',"p4"], -filled => 1, -linecolor => "grey80", -linewidth => 2); - -$zinc->add('text',$group, -position => [25,570], -anchor => 'w', -tags => ['bezier3'], -color => "grey20"); -$zinc->add('curve',$group,[100, 500, 25, 400], -tags => ['line3', 'l1-2'], -linecolor => "#888888", -linewidth => 2); -$zinc->add('curve',$group,[475, 400, 400, 500], -tags => ['line3', 'l3-4'], -linecolor => "#888888", -linewidth => 2); -$zinc->add('curve',$group,[[100, 500], [25, 400, 'c'], [475, 400, 'c'], [400, 500]], - -tags => ['bezier3'], -closed => 0, -linecolor => "red", -linewidth => 5); -$zinc->add('arc',$group,[90, 490, 110, 510], -tags => ['handle3',"p1"], -filled => 1, -linecolor => "grey80", -linewidth => 2); -$zinc->add('arc',$group,[15, 390, 35, 410], -tags => ['handle3',"p2"], -filled => 1, -linewidth => 0, -fillcolor => "grey80", ); -$zinc->add('arc',$group,[465, 390, 485, 410], -tags => ['handle3',"p3"], -filled => 1, -linewidth => 0, -fillcolor => "grey80", ); -$zinc->add('arc',$group,[390, 490, 410, 510], -tags => ['handle3',"p4"], -filled => 1, -linecolor => "grey80", -linewidth => 2); - -$zinc->add('text',$group, -position => [570,570], -anchor => 'w', -tags => ['bezier4'], -color => "grey20"); -$zinc->add('curve',$group,[600, 500, 600, 350], -tags => ['line4', 'l1-2'], -linecolor => "#888888", -linewidth => 2); -$zinc->add('curve',$group,[900, 650, 900, 500], -tags => ['line4', 'l3-4'], -linecolor => "#888888", -linewidth => 2); -$zinc->add('curve',$group,[[600, 500], [600, 350, 'c'], [900, 650, 'c'], [900, 500]], -tags => ['bezier4'], -closed => 0, -linecolor => "red", -linewidth => 5); -$zinc->add('arc',$group,[590, 490, 610, 510], -tags => ['handle4',"p1"], -filled => 1, -linecolor => "grey80", -linewidth => 2); -$zinc->add('arc',$group,[590, 340, 610, 360], -tags => ['handle4',"p2"], -filled => 1, -linewidth => 0, -fillcolor => "grey80"); -$zinc->add('arc',$group,[890, 640, 910, 660], -tags => ['handle4',"p3"], -filled => 1, -linewidth => 0, -fillcolor => "grey80"); -$zinc->add('arc',$group,[890, 490, 910, 510], -tags => ['handle4',"p4"], -filled => 1, -linecolor => "grey80", -linewidth => 2); - -$zinc->add('text',$group, -position => [25,870], -anchor => 'w', -tags => ['bezier5'], -color => "grey20"); -$zinc->add('curve',$group,[100, 800, 175, 700], -tags => ['line5', 'l1-2'], -linecolor => "#888888", -filled => 0, -linewidth => 2); -$zinc->add('curve',$group,[325, 700, 400, 800], -tags => ['line5', 'l3-4'], -linecolor => "#888888", -filled => 0, -linewidth => 2); -$zinc->add('curve',$group,[[100, 800], [175, 700, 'c'], [325, 700, 'c'], [400, 800]], - -tags => ['bezier5'], -closed => 0, -linecolor => "red", -linewidth => 5); -$zinc->add('arc',$group,[90, 790, 110, 810], -tags => ['handle5',"p1"], -filled => 1, -linecolor => "grey80", -linewidth => 2); -$zinc->add('arc',$group,[165, 690, 185, 710], -tags => ['handle5',"p2"], -filled => 1, -linewidth => 0, -fillcolor => "grey80", -filled => 1); -$zinc->add('arc',$group,[315, 690, 335, 710], -tags => ['handle5',"p3"], -filled => 1, -linewidth => 0, -fillcolor => "grey80", -filled => 1); -$zinc->add('arc',$group,[390, 790, 410, 810], -tags => ['handle5',"p4"], -filled => 1, -linecolor => "grey80", -linewidth => 2); - -$zinc->add('text',$group, -position => [570,980], -anchor => 'w', -tags => ['bezier6'], -color => "grey20"); -$zinc->add('curve',$group,[600, 800, 625, 700], -tags => ['line6', 'l1-2'], -linecolor => "#888888", -linewidth => 2); -$zinc->add('curve',$group,[725, 700, 750, 800], -tags => ['line6', 'l3-4'], -linecolor => "#888888", -linewidth => 2); -$zinc->add('curve',$group,[750, 800, 775, 900], -tags => ['line6', 'l4-5'], -linecolor => "#888888", -linewidth => 2); -$zinc->add('curve',$group,[875, 900, 900, 800], -tags => ['line6', 'l6-7'], -linecolor => "#888888", -linewidth => 2); -$zinc->add('curve',$group,[[600, 800], [625, 700, 'c'], [725, 700, 'c'], [750, 800], [775, 900, 'c'], [875, 900, 'c'], [900, 800]], - -tags => ['bezier6'], -filled => 0, -closed => 0, -linecolor => "red", -linewidth => 5); -$zinc->add('arc',$group,[590, 790, 610, 810], -tags => ['handle6',"p1"], -filled => 1, -linecolor => "grey80", -linewidth => 2); -$zinc->add('arc',$group,[615, 690, 635, 710], -tags => ['handle6',"p2"], -filled => 1, -linewidth => 0, -fillcolor => "grey80"); -$zinc->add('arc',$group,[715, 690, 735, 710], -tags => ['handle6',"p3"], -filled => 1, -linewidth => 0, -fillcolor => "grey80"); -$zinc->add('arc',$group,[740, 790, 760, 810], -tags => ['handle6',"p4"], -filled => 1, -linecolor => "blue",-fillcolor => "blue", -linewidth => 2); -$zinc->add('arc',$group,[766, 891, 784, 909], -tags => ['handle6',"p5"], -filled => 1, -linecolor => "grey80", -linewidth => 4); -$zinc->add('arc',$group,[865, 890, 885, 910], -tags => ['handle6',"p6"], -filled => 1, -linewidth => 0, -fillcolor => "grey80"); -$zinc->add('arc',$group,[890, 790, 910, 810], -tags => ['handle6',"p7"], -filled => 1, -linecolor => "grey80", -linewidth => 2); - -$zinc->scale($group, 0.6, 0.6); - -## Set the text of the text item with a tag "tag" -## to a human-readable form of the coords of the -## corresponding curve with the same tag "tag" -sub setText { - my ($tag) = @_; - my $textItem = $zinc->find("withtype", 'text', $tag); - my $curveItem = $zinc->find("withtype", 'curve', $tag); - my @coords = $zinc->coords($curveItem); - my $count = 0; - my $text = "[ "; - while (@coords) { - $refXYc = pop @coords; - my $x=sprintf "%i", $refXYc->[0]; - my $y=sprintf "%i", $refXYc->[1]; - my $t=$refXYc->[2]; - $t = (defined $t) ? ", '".$t."'" : "" ; - $text .= "[$x, $y$t]"; - if (@coords) { $text .= ", "; } - if ($count and @coords) { - $text .= "\n "; - $count =0; - } else { - $count++; - } - } - $text .= " ]"; - $zinc->itemconfigure($textItem, -text => $text); -} - -foreach my $bezierCount (1..6) { - &setText ("bezier".$bezierCount); - my $curveItem = $zinc->find("withtype", 'curve', "bezier".$bezierCount); - my @coords = $zinc->coords($curveItem); -# print "$bezierCount : ", scalar @coords, "\n"; - $zinc->bind("handle$bezierCount", '', [\&press, \&motion]); - $zinc->bind("handle$bezierCount", '', [\&release]); -} - - - -&Tk::MainLoop; - - -##### bindings for moving the handles -my ($cur_x, $cur_y,$item, $bezierNum, $ptNum); -sub press { - my ($zinc, $action) = @_; - my $ev = $zinc->XEvent(); - $cur_x = $ev->x; - $cur_y = $ev->y; - $item = $zinc->find('withtag', 'current'); - $zinc->bind($item, '', [$action]); - foreach ( $zinc->gettags($item) ) { - ## looking for the tag "handlei" - if ( /^handle(\d+)$/ ) { - $bezierNum = $1; - } - ## looking for the tag "pj" - if ( /^p(\d+)$/ ) { - $ptNum = $1; - } - } -# print "bezierNum=$bezierNum ptNum=$ptNum\n"; -} - -sub motion { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my ($dx,$dy) = $zinc->transform($group, [$lx-$cur_x, $ly-$cur_y]); - &moveHandle($item,$dx,$dy); - my ($pt1,$pt2) = $zinc->coords($item); -# print "coords=",@{$pt1}, " ",@{$pt2},"\n"; - $cur_x = $lx; - $cur_y = $ly; -} - -sub release { - my ($zinc) = @_; - $zinc->bind($item,'', ''); - $item = ""; -} - -sub moveHandle { - my ($item,$dx,$dy) = @_; - my ($pt1,$pt2) = $zinc->coords($item); - ## modifying the handle coords - $zinc->coords($item, [ $pt1->[0]+$dx, $pt1->[1]+$dy, $pt2->[0]+$dx, $pt2->[1]+$dy]); - my $prevPtNum = $ptNum-1; - # there should only be one such item! - my $lineA = $zinc->find("withtag", "line$bezierNum && l$prevPtNum-$ptNum"); - if (defined $lineA) { - my ($x,$y) = $zinc->coords($lineA,0,1); # to get the 2nd point coords - $zinc->coords($lineA, 0,1, [ $x+$dx, $y+$dy ]); - } - - my $nextPtNum = $ptNum+1; - # there should only be one such item: - my ($lineB) = $zinc->find("withtag", "line$bezierNum && l$ptNum-$nextPtNum"); - if (defined $lineB) { - my ($x,$y) = $zinc->coords($lineB,0,0); # to get the 1st point coords - $zinc->coords($lineB, 0,0, [ $x+$dx, $y+$dy ] ); - } - - my ($x,$y,$control) = $zinc->coords("bezier$bezierNum", 0,$ptNum-1); - $zinc->coords("bezier$bezierNum", 0,$ptNum-1, [ [$x+$dx, $y+$dy, $control] ] ); - &setText ("bezier$bezierNum"); - -} - diff --git a/Perl/demos/Tk/demos/zinc_lib/fillrule.pl b/Perl/demos/Tk/demos/zinc_lib/fillrule.pl deleted file mode 100644 index 08ec781..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/fillrule.pl +++ /dev/null @@ -1,101 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# This simple demo has been developped by C. Mertz - -####### This file has been largely inspired from figure 11-3 -####### of "The OpenGL Programming Guide 3rd Edition, The -####### Official Guide to Learning OpenGL Version 1.2", ISBN 0201604582 - -####### it illustrates the use of : -####### -fillrule attribute of curves -####### contour, coords and clone method - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk::Zinc; - - -my $mw = MainWindow->new(); -$mw->title('example of multiple contours and fillrule usage'); - -my $zinc = $mw->Zinc(-width => 510, -height => 630, - -font => "10x20", - -font => "9x15", - -borderwidth => 0, - -backcolor => "white", - )->pack; - -$zinc->add('text', 1, -position => [20,8], -text => "This (still static) example reproduces figure 11-3 -of \"The OpenGL Programming Guide 3rd Edition\" V 1.2"); - -my $group = $zinc->add('group', 1); - -my $g1 = $zinc->add('group', $group); -my $curve1 = $zinc->add('curve',$g1, []); -$zinc->contour($curve1, "add", +1, [ 0,0, 0,120, 120,120, 120,0, 0,0]); -$zinc->contour($curve1, "add", +1, [ 20,20, 20,100, 100,100, 100,20, 20,20]); -$zinc->contour($curve1, "add", +1, [ 40,40, 40,80, 80,80, 80,40, 40,40]); -$zinc->translate($g1, 40,40); - - -my $g2 = $zinc->add('group', $group); -my $curve2 = $zinc->add('curve',$g2, []); -$zinc->contour($curve2, "add", +1, [ 0,0, 0,120, 120,120, 120,0, 0,0]); -$zinc->contour($curve2, "add", -1, [ 20,20, 20,100, 100,100, 100,20, 20,20]); -$zinc->contour($curve2, "add", -1, [ 40,40, 40,80, 80,80, 80,40, 40,40]); -$zinc->translate($g2, 200,40); - - -my $g3 = $zinc->add('group', $group); -my $curve3 = $zinc->add('curve',$g3, []); -$zinc->contour($curve3, "add", +1, [ 20,0, 20,120, 100,120, 100,0, 20,0]); -$zinc->contour($curve3, "add", +1, [ 40,20, 60,120, 80,20, 40,20]); -$zinc->contour($curve3, "add", +1, [ 0,60, 0,80, 120,80, 120,60, 0,60]); -$zinc->translate($g3, 360,40); - -my $g4 = $zinc->add('group', $group); -my $curve4 = $zinc->add('curve',$g4, []); -$zinc->contour($curve4, "add", +1, [ 0,0, 0,140, 140,140, 140,60, 60,60, 60,80, 80,80, 80,40, 40,40, - 40,100, 100,100, 100,20, 20,20, - 20,120, 120,120, 120,0, 0,0]); -$zinc->translate($g4, 520,40); - -$zinc->scale($group, 0.6, 0.6); -$zinc->translate($group, 80,20); - -$zinc->add('text',$group, -position => [-110, 40], -text => "contours\nand\nwinding\nnumbers"); -$zinc->add('text',$group, -position => [-110, 170], -text => "winding\nrules"); -my $dy = 0; -foreach my $fillrule ('odd', 'nonzero', 'positive', 'negative', 'abs_geq_2') { - $dy += 160; - $zinc->add('text',$group, -position => [-110, 100+$dy], -text => $fillrule eq 'odd' ? "odd\n(default)" : $fillrule); - foreach my $item ($curve1, $curve2, $curve3, $curve4) { - my $clone = $zinc->clone($item, -fillrule => $fillrule, -filled => 1); - $zinc->translate($clone, 0,$dy); - } -} - -# creating simple lines with arrows under each curves -foreach my $item ($curve1, $curve2, $curve3, $curve4) { - my $contour_number = $zinc->contour($item); -# print "$item => contour_number=$contour_number\n"; - foreach my $n (0..$contour_number-1) { - my @points = $zinc->coords($item,$n); -# print " ",$#points,"points\n"; - foreach my $i (0 .. $#points-1) { -# print " line $i ",$i+1,"\n"; - $firstpoint = $points[$i]; - $lastpoint = $points[$i+1]; - $middlepoint = [$firstpoint->[0]+($lastpoint->[0]-$firstpoint->[0])/1.5, - $firstpoint->[1]+($lastpoint->[1]-$firstpoint->[1])/1.5]; - $zinc->add("curve", $zinc->group($item), - [ $firstpoint, $middlepoint], - -lastend => [7,10,4]); - } - } -} -&Tk::MainLoop; - - - diff --git a/Perl/demos/Tk/demos/zinc_lib/groups_in_ATC_strips.pl b/Perl/demos/Tk/demos/zinc_lib/groups_in_ATC_strips.pl deleted file mode 100644 index 74cc71c..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/groups_in_ATC_strips.pl +++ /dev/null @@ -1,910 +0,0 @@ -#!/usr/bin/perl -w -#----------------------------------------------------------------------------------- -# -# Copyright (C) 2002 -# Centre d'Études de la Navigation Aérienne -# -# Authors: Jean-Luc Vinot for whole graphic design and coding -# Christophe Mertz for adding simple animations -# and integration in zinc-demos -# This integration is still not perfect and requires an extension in zinc -# We must know if a neamed gradient already exists, when launching -# many time the same demo in the same process! -# -# $Id$ -#----------------------------------------------------------------------------------- -# This small application illustrates both the use of groups in combination -# of -composescale attributes and an implementation of kind of air traffic -# control electronic strips. -# However it is only a simplified example given as is, without any immediate usage! -# -# 3 strips formats are accessible through "+" / "-" buttons on the right side -# -# 1. small-format: with 2 lines of info, and reduced length -# -# 2. normal-format: with 3 lines of info, full length -# -# 3. extended-format: with 3 lines of infos, full length -# the 3 lines are zoomed -# an additionnel 4th lone is displayed -# -# An additionnal 4th format (micro-format) is available when double-clicking somewhere... -# -# Strips can be moved around by drag&drop from the callsign -# -# When changing size, strips are animated. The animation is a very simple one, -# which should be enhanced.... You can change the animation parameters, by modifyng -# $delay and $steps. -# -#----------------------------------------------------------------------------------- - -package groups_in_ATC_strips; # for avoiding symbol collision between different demos - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; - -$| = 1; - - -my @stripGradiants; -my %stripFontset; -my %textures; - -my $oldfkey; -my ($dx, $dy); - -my $delay = 50; # ms between each animation steps -my $steps = 6; # number of steps for the animation -my %scales; # this hash just memorizes the current x and y scaling ratio - # In a real appli, this should be memorized in strip objects - -#---------------------- -# configuration data -#---------------------- -my $fnb10 = 'cenapii-digistrips-b10'; -my $fnb10c = 'cenapii-digistrips-b10c'; -my $fnb11 = 'cenapii-digistrips-b11'; -my $fnb12 = 'cenapii-digistrips-b12'; -my $fnb15 = 'cenapii-radar-b15'; -my $fnm20 = 'cenapii-radar-m20'; -my $fne18 = 'cenapii-radar-m18'; - -my @ratio2fontset = ([1.2, 'normal'], - [10, 'large']); - -my $mwidth = 700; -my $mheight = 500; - -my %stripstyle = (-gradset => {'idnt' => '=axial 90 |#ffffff 0|#ffeedd 30|#e9d1ca 90|#e9a89a', - 'back' => '=axial 0 |#c1daff|#8aaaff', - ## the following shadow gradient is sub-optimal - 'shad' => '=path -40 -40 |#000000;50 0|#000000;50 92|#000000;0 100', - 'btn_outside' => '=axial 0 |#ffeedd|#8a9acc', - 'btn_inside' => '=axial 180 |#ffeedd|#8a9acc', - 'ch1' => '=axial 0 |#8aaaff|#5B76ED', - }, - - -fontset => {'normal' => {'callsign' => $fnb15, - 'type1' => $fnb12, - 'type2' => $fnb10, - 'type3' => $fnb10c, - }, - - 'large' => {'callsign' => $fnm20, - 'type1' => $fne18, - 'type2' => $fnb15, - 'type3' => $fnb12, - }, - }, - - -width => 340, - -height => 86, - -shadowcoords => [8, 8, 374, 94], - -shadowcolor => 'shad', - - -strip => {-linewidth => 3, - -linecolor => '#aaccff', - -fillcolor => 'back', - -relief => 'roundraised', - }, - - -buttons => {-coords => [340, 0], - -clipcoords => [0, 0, 90, 83], - -zone => {-coords => [0, 0, 26, 85], - -fillcolor => 'btn_outside', - -linewidth => 0, - }, - - -btns => {'btnup' => {-coords => [0, 0, 26, 43], - -arrow => [14, 2, 24, 40, - 1, 40, 14, 2], - -linewidth => 1, - -linecolor => '#aabadd', - -fillcolor => 'btn_inside', - -label => {-coords => [13, 27], - -text => "+", - -font => $fnm20, - -color => '#ffffff', - -anchor => 'center', - }, - }, - - 'btndn' => {-coords => [0, 43, 26, 86], - -arrow => [14, 83, 24, 43, - 1, 43, 14, 83], - -linewidth => 1, - -linecolor => '#aabadd', - -fillcolor => 'btn_inside', - -label => {-coords => [13, 56], - -text => "-", - -font => $fnm20, - -color => '#ffffff', - -anchor => 'center', - }, - }, - }, - }, - - -clipcoords => [3, 3, 332, 80], - -zones => {'ident' => {-coords => [3, 3, 90, 50], - -atomic => 1, - -priority => 200, - -sensitive => 1, - -tags => "move", - -linewidth => 1, - -filled => 1, - -relief => 'sunken', - -linecolor => '#ffeedd', - -fillcolor => 'idnt', - -fields => {-callsign => {-coords => [10, 18], - -font => 'callsign', - -text => 'EWG361', - -anchor => 'w', - -color => '#000000', - }, - -company => {-coords => [10, 34], - -font => 'type2', - -text => 'Eurowing', - -anchor => 'w', - -color => '#444444', - }, - }, - }, - 'input' => {-coords => [3, 3, 334, 82], - -atomic => 1, - -priority => 100, - -sensitive => 1, - -tags => "scale", - -linewidth => 0, - -filled => 1, - -relief => 'flat', - -linecolor => 'white', - -fillcolor => 'back', #'#afb2cc', - -fields => {-type => {-coords => [100, 18], - -font => 'type1', - -text => 'TYPA', - -anchor => 'w', - -color => '#444444', - }, - -cfmu => {-coords => [200, 18], - -font => 'type1', - -text => '08:26', - -anchor => 'e', - -color => '#444444', - }, - -ptsid => {-coords => [100, 40], - -font => 'type2', - -text => 'NIPOR', - -anchor => 'w', - -color => '#444444', - }, - -confsid => {-coords => [158, 40], - -font => 'type2', - -text => '8G', - -anchor => 'center', - -color => '#444444', - }, - -park => {-coords => [200, 40], - -font => 'type2', - -text => 'G23', - -anchor => 'e', - -color => '#444444', - }, - - -dest => {-coords => [10, 66], - -font => 'type2', - -text => 'DEST', - -anchor => 'w', - -color => '#555555', - }, - -champ1 => {-type => 'rect', - -coords => [45, 56, - 135, 76], - -filled => 1, - -fillcolor => 'ch1', - -linecolor => 'white', - -linewidth => 0, - }, - -bret => {-coords => [200, 66], - -font => 'type2', - -text => 'Bret.', - -anchor => 'e', - -color => '#444444', - }, - }, - }, - - 'zreco' => {-coords => [210, 3, 346, 82], - -atomic => 1, - -priority => 200, - -texture => "stripped_texture.gif", - -sensitive => 1, - -tags => "edit", - -linewidth => 2, - -filled => 1, - -relief => 'sunken', - -linecolor => '#deecff', - -fillcolor => '#d3e5ff', - }, - - - }, - - -zinfo => {-coords => [0, 86], - -rectcoords => [0, 0, 340, 20], - -shadowcoords => [8, 8, 348, 28], - -shadowcolor => 'shad', - -atomic => 1, - -priority => 200, - -sensitive => 1, - -tags => "edit2", - -linewidth => 2, - -linecolor => '#aaccff', - -fillcolor => 'back', - -relief => 'roundraised', - -fields => {-ssr => {-coords => [4, 10], - -font => 'type3', - -text => '7656', - -anchor => 'w', - -color => '#444444', - }, - -pdep => {-coords => [47, 10], - -font => 'type3', - -text => 'G23', - -anchor => 'center', - -color => '#444444', - }, - -qfu => {-coords => [73, 10], - -font => 'type3', - -text => '09R', - -anchor => 'center', - -color => '#444444', - }, - -slabel => {-coords => [105, 10], - -font => 'type3', - -text => 'vit:', - -anchor => 'e', - -color => '#444444', - }, - -speed => {-coords => [106, 10], - -font => 'type3', - -text => '260', - -anchor => 'w', - -color => '#444444', - }, - -pper => {-coords => [142, 10], - -font => 'type3', - -text => 'EPL', - -anchor => 'center', - -color => '#444444', - }, - -rfl => {-coords => [166, 10], - -font => 'type3', - -text => '210', - -anchor => 'center', - -color => '#444444', - }, - -cautra => {-coords => [183, 10], - -font => 'type3', - -text => '8350', - -anchor => 'w', - -color => '#444444', - }, - -nsect => {-coords => [219, 10], - -font => 'type3', - -text => 'MOD', - -anchor => 'w', - -color => '#444444', - }, - -day => {-coords => [297, 10], - -font => 'type3', - -text => '21/05/02', - -anchor => 'e', - -color => '#444444', - }, - -hour => {-coords => [332, 10], - -font => 'type3', - -text => '13:50', - -anchor => 'e', - -color => '#444444', - }, - }, - - }, - ); - -# creation de la fenetre principale -my $mw; -$mw = MainWindow->new(); - -# The explanation displayed when running this demo -my $text = $mw->Text(-relief => 'sunken', -borderwidth => 2, - -setgrid => 'true', -height =>7); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', -'These fake air Traffic Control electronic strips illustrates - the use of groups for an advanced graphic design. -The following interactions are possible: - "drag&drop button1" on the callsign. - "button 1" triangle buttons on the right side of the strips - to modify strips size - "double click 1" on the blueish zone to fully reduce size'); - -$mw->title('ATC strips using groups'); - - -#------------------------ -# creation du widget Zinc -my $zinc = $mw->Zinc(-render => 1, - -width => $mwidth, - -height => $mheight, - -borderwidth => 0, - -lightangle => 130, - ); - -$zinc->pack(-fill => 'both', -expand => 1); - -my $texture = $zinc->Photo('background_texture.gif', - -file => Tk->findINC('demos/zinc_data/background_texture.gif')); -$zinc->configure(-tile => $texture) if $texture; - - - -my ($xn, $yn) = (10, 30); - -# test Strips -for (my $index = 0; $index < 4 ; $index++) { - - &createStrip($index, $xn, $yn, \%stripstyle); - - $xn += 50; - $yn += 120; - -} - - -&initBindings('move', 'scale'); - - - - -Tk::MainLoop; - -#----------------------------------------------------------------------- fin de MAIN - - -# Création du Strip -sub createStrip { - my ($index, $x, $y, $style) = @_; - - # initialise les gradiants - unless (@stripGradiants) { - my %gradiants = %{$style->{'-gradset'}}; - my ($name, $gradiant); - while (($name, $gradiant) = each(%gradiants)) { - # création des gradients nommés - $zinc->gname($gradiant, $name) unless $zinc->gname($gradiant); - # the previous test is usefull only - # when this script is executed many time in the same process - # (it is typically the case in zinc-demos) - - push(@stripGradiants, $name); - } - } - - # initialise les jeux de fontes - unless (%stripFontset) { - %stripFontset = %{$style->{'-fontset'}}; - } - - # création du groupe de base : coords - my $g1 = $zinc->add('group', 1, -priority => 100, -tags => ["base".$index]); - $zinc->coords($g1, [$x, $y]); - - # group de transfo 1 : scaling (à partir du coin haut droit) - my $g2 = $zinc->add('group', $g1, -tags => ["scaling".$index]); - - - #------------------------------------------------------------- - # réalisation du strip lui même (papier support + ombre portée - #------------------------------------------------------------- - - # params strip - my $stripw = $style->{'-width'}; - my $striph = $style->{'-height'}; - - # ombre portée - $zinc->add('rectangle', $g2, - $style->{'-shadowcoords'}, - -filled => 1, - -linewidth => 0, - -fillcolor => $style->{'-shadowcolor'}, - -priority => 10, - -tags => ["shadow".$index], - ); - - - # strip - my $sstyle = $style->{'-strip'}; - my $strip = $zinc->add('rectangle', $g2, - [0, 0, $stripw, $striph], - -filled => 1, - -linewidth => $sstyle->{'-linewidth'}, - -linecolor => $sstyle->{'-linecolor'}, - -fillcolor => $sstyle->{'-fillcolor'}, - -relief => $sstyle->{'-relief'}, - -priority => 20, - -tags => ["strip".$index], - ); - - if ($sstyle->{'-texture'}) { - if (!exists($textures{'-strip'})) { - my $texture = $zinc->Photo($sstyle->{'-texture'}, - -file => Tk->findINC("demos/zinc_data/".$sstyle->{-texture})); - $textures{'-strip'} = $texture; - } - - $zinc->itemconfigure($strip, -tile => $textures{'-strip'}); - } - - - #------------------------------------------------- - # ajout de la zone des boutons (à droite du strip) - #------------------------------------------------- - if ($style->{'-buttons'}) { - my $bstyle = $style->{'-buttons'}; - - # le groupe de la zone bouton - my $btngroup = $zinc->add('group', $g2, -priority => 40); - $zinc->coords($btngroup, $bstyle->{'-coords'}); - - # sa zone de clipping - my $btnclip = $zinc->add('rectangle', $btngroup, - $bstyle->{'-clipcoords'}, - -filled => 0, - -visible => 0, - ); - - # le clipping du groupe bouton - $zinc->itemconfigure($btngroup, -clip => $btnclip); - - # zone bouton - $zinc->add('rectangle', $btngroup, - $bstyle->{'-zone'}->{'-coords'}, - -filled => 1, - -linewidth => $bstyle->{'-zone'}->{'-linewidth'}, - -fillcolor => $bstyle->{'-zone'}->{'-fillcolor'}, - -composescale => 0, - -tags => ["content".$index], - ); - - - my %btns = %{$bstyle->{'-btns'}}; - my ($name, $btnstyle); - while (($name, $btnstyle) = each(%btns)) { -# print "bouton $name $btnstyle\n"; - - my $sgroup = $zinc->add('group', $btngroup, - -atomic => 1, - -sensitive => 1, - -composescale => 0, - -tags => [$name.$index, "content".$index], - ); - - $zinc->add('rectangle', $sgroup, - $btnstyle->{'-coords'}, - -filled => 1, - -visible => 0, - -priority => 100, - ); - - $zinc->add('curve', $sgroup, - $btnstyle->{'-arrow'}, - -closed => 1, - -filled => 1, - -linewidth => $btnstyle->{'-linewidth'}, - -linecolor => $btnstyle->{'-linecolor'}, - -fillcolor => $btnstyle->{'-fillcolor'}, - -priority => 50, - ); - - $zinc->add('text', $sgroup, - -position => $btnstyle->{'-label'}->{'-coords'}, - -text => $btnstyle->{'-label'}->{'-text'}, - -font => $btnstyle->{'-label'}->{'-font'}, - -color => $btnstyle->{'-label'}->{'-color'}, - -anchor => $btnstyle->{'-label'}->{'-anchor'}, - -priority => 60, - ); - } - - # bindings boutons Up et Down du Strip - $zinc->bind('btnup'.$index, '<1>', \&extendedStrip); - $zinc->bind('btndn'.$index, '<1>', \&smallStrip); - - } - - # construction du contenu du strip - &buildContent($index, $g2, 100, $style); - - # et de la barre d'extension info (extended format) - &buildExtent($index, $g2, $style->{'-zinfo'}); - -} - - -# Construction des zones internes du Strips -sub buildContent { - my ($index, $parent, $priority, $style) = @_; - - # group content - my $g3 = $zinc->add('group', $parent, -priority => $priority); - - # zone de clipping - my $clip = $zinc->add('rectangle', $g3, - $style->{'-clipcoords'}, - -filled => 0, - -visible => 0, - ); - - # clipping du groupe content - $zinc->itemconfigure($g3, -clip => $clip); - - # création d'un group intermédiaire pour bloquer le scaling - my $g4 = $zinc->add('group', $g3, - -composescale => 0, - -tags => ["content".$index], - ); - - # création des zones - my %zones = %{$style->{'-zones'}}; - my ($name, $zonestyle); - while (($name, $zonestyle) = each(%zones)) { - # group de zone - my $gz = $zinc->add('group', $g4); - - if ($zonestyle->{'-atomic'}) { - $zinc->itemconfigure($gz, -atomic => 1, - -sensitive => $zonestyle->{'-sensitive'}, - -priority => $zonestyle->{'-priority'}, - -tags => [$name.$index, $zonestyle->{'-tags'}], - ); - } - - my $rectzone = $zinc->add('rectangle', $gz, - $zonestyle->{'-coords'}, - -filled => $zonestyle->{'-filled'}, - -linewidth => $zonestyle->{'-linewidth'}, - -linecolor => $zonestyle->{'-linecolor'}, - -fillcolor => $zonestyle->{'-fillcolor'}, - -relief => $zonestyle->{'-relief'}, - -priority => 10, - -tags => [$name.$index], - ); - - if ($zonestyle->{'-texture'}) { - if (!exists($textures{$name})) { - my $texture = $zinc->Photo($zonestyle->{'-texture'}, - -file => Tk->findINC("demos/zinc_data/".$zonestyle->{-texture})); - $textures{$name} = $texture; - } - - $zinc->itemconfigure($rectzone, -tile => $textures{$name}); - } - - - my %fields; - %fields = %{$zonestyle->{'-fields'}} if (defined $zonestyle->{'-fields'}) ; - my ($field, $fieldstyle); - my $fontsty = $stripFontset{'normal'}; - while ( ($field, $fieldstyle) = each(%fields) ) { - if ($fieldstyle->{'-type'} and $fieldstyle->{'-type'} eq 'rect') { - $zinc->add('rectangle', $gz, - $fieldstyle->{'-coords'}, - -filled => $fieldstyle->{'-filled'}, - -fillcolor => $fieldstyle->{'-fillcolor'}, - -linewidth => $fieldstyle->{'-linewidth'}, - -linecolor => $fieldstyle->{'-linecolor'}, - -priority => 20, - ); - } else { - - my $font = $fieldstyle->{'-font'}; -# print "buildContent field:$field font:$font\n"; - $zinc->add('text', $gz, - -position => $fieldstyle->{'-coords'}, - -text => $fieldstyle->{'-text'}, - -font => $fontsty->{$font}, - -color => $fieldstyle->{'-color'}, - -anchor => $fieldstyle->{'-anchor'}, - -priority => 30, - -tags => [$font.$index], - ); - } - - } - - } -} - - -# Construction de la barre d'extension info du Strip -sub buildExtent { - my ($index, $parent, $infostyle) = @_; - - # group content - my $extgroup = $zinc->add('group', $parent); - $zinc->coords($extgroup, $infostyle->{'-coords'}); - - $zinc->itemconfigure($extgroup, - -atomic => $infostyle->{'-atomic'}, - -sensitive => $infostyle->{'-sensitive'}, - -priority => $infostyle->{'-priority'}, - -visible => 0, - -tags => ["zinfo".$index, $infostyle->{'-tags'}], - ); - - # ombre portée - $zinc->add('rectangle', $extgroup, - $infostyle->{'-shadowcoords'}, - -filled => 1, - -linewidth => 0, - -fillcolor => $infostyle->{'-shadowcolor'}, - -priority => 10, - -tags => ["shadow".$index], - ); - - my $rectzone = $zinc->add('rectangle', $extgroup, - $infostyle->{'-rectcoords'}, - -filled => 1, - -linewidth => $infostyle->{'-linewidth'}, - -linecolor => $infostyle->{'-linecolor'}, - -fillcolor => $infostyle->{'-fillcolor'}, - -relief => $infostyle->{'-relief'}, - -priority => 20, - ); - - if ($infostyle->{'-texture'}) { - if (!exists($textures{'-zinfo'})) { - my $texture = $zinc->Photo($infostyle->{'-texture'}, - -file => Tk->findINC("demos/zinc_data/".$infostyle->{-texture})); - $textures{'-zinfo'} = $texture; - } - $zinc->itemconfigure($rectzone, -tile => $textures{'-zinfo'}); - - } - - my %fields = %{$infostyle->{'-fields'}}; - my ($field, $fieldstyle); - my $fontsty = $stripFontset{'normal'}; - while (($field, $fieldstyle) = each(%fields)) { - if ($fieldstyle->{'-type'} and $fieldstyle->{'-type'} eq 'rect') { - $zinc->add('rectangle', $extgroup, - $fieldstyle->{'-coords'}, - -filled => $fieldstyle->{'-filled'}, - -fillcolor => $fieldstyle->{'-fillcolor'}, - -linewidth => $fieldstyle->{'-linewidth'}, - -linecolor => $fieldstyle->{'-linecolor'}, - -priority => 40, - ); - } else { - - my $font = $fieldstyle->{'-font'}; -# print "buildContent field:$field font:$font\n"; - $zinc->add('text', $extgroup, - -position => $fieldstyle->{'-coords'}, - -text => $fieldstyle->{'-text'}, - -font => $fontsty->{$font}, - -color => $fieldstyle->{'-color'}, - -anchor => $fieldstyle->{'-anchor'}, - -priority => 50, - -tags => [$font.$index], - ); - } - - } - -} - -# initialisation des bindings généraux dy Strip -sub initBindings { - my ($movetag, $scaletag) = @_; - - $zinc->bind($movetag, '<1>', \&catchStrip); - $zinc->bind($movetag, '', \&releaseStrip); - $zinc->bind($movetag, '', \&motionStrip); - - $zinc->bind($scaletag, '', \µStrip); - -} - -# Callback CATCH de début de déplacement du Strip -sub catchStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0], 5); - - my ($x, $y) = $zinc->coords("base".$index); - my $ev = $zinc->XEvent; - ($dx, $dy) = ($x - $ev->x, $y - $ev->y); - - $zinc->itemconfigure("base".$index, -priority => 200); - -} - -# Callback MOVE de fin de déplacement du Strip -sub motionStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0], 5); - my $ev = $zinc->XEvent; - $zinc->coords("base".$index, [$ev->x + $dx, $ev->y + $dy]); - -} - -# Callback RELEASE de fin de déplacement du Strip -sub releaseStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0], 5); - $zinc->itemconfigure("base".$index, -priority => 100); -} - -# Zoom Strip : normal format -sub normalStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0], 5); - - $zinc->itemconfigure("input".$index, -sensitive => 1); - - &displayRecoZone($index, 1); - &displayExtentZone($index, 0); - &configButtons($index, \&extendedStrip, \&smallStrip); - &changeStripFormat($index, 1, 1, 0, 1); -} - -# Zoom Strip : small format (lignes 1 et 2) -sub smallStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0], 5); - - &displayRecoZone($index, 0); - &configButtons($index, \&normalStrip, 0); - &changeStripFormat($index, 1, .63, 0, 1); -} - -# Zoom Strip : micro format (zone ident) -sub microStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0], 5); - - &configButtons($index, \&normalStrip, 0); - &changeStripFormat($index, .28, .63, 0, 1); - -} - -# Zoom Strip : extendedFormat -sub extendedStrip { - my $index = substr(($zinc->itemcget('current', -tags))[0],5); - - $zinc->itemconfigure("input".$index, -sensitive => 0); - $zinc->itemconfigure("base".$index, -priority => 150); - &displayRecoZone($index, 0); - &displayExtentZone($index, 1); - &configButtons($index, 0, \&normalStrip); - &changeStripFormat($index, 1.3, 1.3, 1, 1.3); -} - - -# affiche/masque la zone Reco -sub displayRecoZone { - my ($index, $state) = @_; - my $priority = ($state) ? 200 : 0; - $zinc->itemconfigure("zreco".$index, -priority => $priority); -} - - -# affiche/masque la zone Extent -sub displayExtentZone { - my ($index, $state) = @_; - - $zinc->itemconfigure("zinfo".$index, - -visible => $state, - -sensitive => $state); -} - -# Configure affichage et callbacks des boutons du Strip -sub configButtons { - my ($index, $funcUp, $funcDown) = @_; - - # button Up - $zinc->itemconfigure("btnup".$index, -visible => $funcUp); - $zinc->bind('btnup'.$index, '<1>', $funcUp) if $funcUp; - - # button Down - $zinc->itemconfigure("btndn".$index, -visible => $funcDown); - $zinc->bind('btndn'.$index, '<1>', $funcDown) if $funcDown; - -} - - -# this function has been hacked to provide the user with an animation -# The animation is (too) simple but provide a better feedback than without -sub changeStripFormat { - my ($index, $xratio, $yratio, $composeflag, $fontratio) = @_; - - # réinitialisation du groupe scaling - $zinc->treset("scaling".$index); - - # configure le blocage de transformation du format des champs - $zinc->itemconfigure("content".$index, -composescale => $composeflag); - - # applique le nouveau scaling - $scales{$index} = [1,1] unless defined $scales{$index}; - my ($oldXratio,$oldYratio) = @{$scales{$index}}; - $scales{$index}=[$xratio, $yratio]; - my $dx = ($xratio - $oldXratio) / $steps; - my $dy = ($yratio - $oldYratio) / $steps; - &_resize($index, $delay, $oldXratio+$dx, $oldYratio+$dy, $dx, $dy, $steps); -} - -sub _resize { - my ($index, $delay, $newXratio, $newYratio, $dx, $dy, $steps) = @_; - $zinc->treset("scaling".$index); - $zinc->scale("scaling".$index, $newXratio, $newYratio); - # jeu de fontes - &setFontes($index, $newYratio); - $steps--; - $zinc->after($delay, sub {&_resize ($index, $delay, $newXratio+$dx, $newYratio+$dy, $dx, $dy, $steps)}) - if $steps > 0; -} - -sub getFKey { - my ($ratio) = @_; - my $newfkey; - - foreach my $param (@ratio2fontset) { - my ($maxratio, $fkey) = @{$param}; - $newfkey = $fkey; - if ($ratio < $maxratio) { - return $newfkey; - } - } - - return $newfkey; -} - - -sub setFontes { - my ($index, $ratio) = @_; - my $newfkey = &getFKey($ratio); - - if (!$oldfkey or $oldfkey ne $newfkey) { - my $fontsty = $stripFontset{$newfkey}; -# print "setFontes $oldfkey -> $newfkey\n"; - if ($fontsty) { - foreach my $type ('callsign', 'type1', 'type2', 'type3') { - $zinc->itemconfigure($type.$index, -font => $fontsty->{$type}); - } - } - - $oldfkey = $newfkey; - } -} - diff --git a/Perl/demos/Tk/demos/zinc_lib/groups_priority.pl b/Perl/demos/Tk/demos/zinc_lib/groups_priority.pl deleted file mode 100644 index e7f872d..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/groups_priority.pl +++ /dev/null @@ -1,261 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# This simple demo has been developped by C. Mertz - -package groups_priority; # for avoiding symbol sharing between different demos - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; - -use strict; - -my $mw = MainWindow->new(); - -# The explanation displayed when running this demo -my $text = $mw->Text(-relief => 'sunken', -borderwidth => 2, - -height => 12); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', -'There are two groups (a red one and a green one) each containing - 4 rectangles. Those rectangles display their current priority. -The following operations are possible: - "Mouse Button 1" for dragging objects. - "Mouse Button 2" for dragging a colored group. - "Key +" on a rectangle to raise it inside its group. - "Key -" on a rectangle to lower it inside its group. - "Key l" on a rectangle to lower its colored group. - "Key r" on a rectangle to raise its colored group. - "Key t" on a rectangle to change its group (but not its color!). - "Key [0-9] on a rectangle to set the priority to [0-9] -Raising or lowering an item inside a group modify its priority if necessary'); - -# Creating the zinc widget -my $zinc = $mw->Zinc(-width => 600, -height => 500, - -font => "10x20", # usually fonts are sets in resources - # but for this example it is set in the code! - -borderwidth => 3, -relief => 'sunken', - )->pack; - -#########################################################################" -# Creating the redish group -my $group1 = $zinc->add('group', 1, -visible => 1); - -my $counter=0; -# Adding 4 rectangles with text to redish group -foreach my $data ( [200,100, 'red'], [210,210,'red1'], - [390,110,'red2'], [395,215,'red3'] ) { - $counter += 2; - my ($centerx,$centery,$color) = @{$data}; - # this small group is for merging together : - # the rectangle and the text showing its name - my $g = $zinc->add('group', $group1, - -visible => 1, - -atomic => 1, - -sensitive => 1, - -priority => $counter, - ); - my $rec = $zinc->add('rectangle', $g, [$centerx-100,$centery-60, - $centerx+100, $centery+60], - -fillcolor => $color, -filled => 1, - ); - my $txt = $zinc->add('text', $g, - -position => [$centerx,$centery], - -text => "pri=$counter", - -anchor => 'center', - ); - # Some bindings for dragging the rectangle or the full group - $zinc->bind($g, '' => [\&press, $g, \&motion]); - $zinc->bind($g, '' => \&release); - $zinc->bind($g, '' => [\&press, $g, \&groupMotion]); - $zinc->bind($g, '' => \&release); -} - -#########################################################################" -# Creating the greenish group -my $group2 = $zinc->add('group', 1, -visible => 1); -$counter=0; - -# Adding 4 rectangles with text to greenish group -foreach my $data ( [200,300,'green1'], [210,410,'green2'], - [390,310,'green3'], [395,415,'green4'] ) { - $counter++; - my ($centerx,$centery,$color) = @{$data}; - # this small group is for merging together a rectangle - # and the text showing its priority - my $g = $zinc->add('group', $group2, - -atomic => 1, - -sensitive => 1, - -priority => $counter, - ); - my $rec = $zinc->add('rectangle', $g, [$centerx-100,$centery-60, - $centerx+100, $centery+60], - -fillcolor => $color, -filled => 1, - ); - my $txt = $zinc->add('text', $g, - -position => [$centerx,$centery], - -text => "pri=$counter", - -anchor => 'center', - ); - # Some bindings for dragging the rectangle or the full group - $zinc->bind($g, '' => [\&press, $g, \&motion]); - $zinc->bind($g, '' => \&release); - $zinc->bind($g, '' => [\&press, $g, \&groupMotion]); - $zinc->bind($g, '' => \&release); -} - - -#########################################################################" -# adding the key bindings - -# the focus on the widget is ABSOLUTELY necessary for key bindings! -$zinc->Tk::focus(); - -$zinc->Tk::bind('' => \&raiseGroup); -$zinc->Tk::bind('' => \&lowerGroup); -$zinc->Tk::bind('' => \&raise); -$zinc->Tk::bind('' => \&raise); -$zinc->Tk::bind('' => \&lower); -$zinc->Tk::bind('' => \&lower); -$zinc->Tk::bind('' => \&toggleItemGroup); - -my @KP_MAPPINGS = qw (Insert End Down Next Left Begin Right Home Up Prior); - -for my $i (0..9) { - $zinc->Tk::bind("" => [\&setPriorrity, $i]); - my $code = $KP_MAPPINGS[$i]; - $zinc->Tk::bind("" => [\&setPriorrity, $i]); -} - -# The following binding is currently not possible; only text items -# with focus can get a KeyPress or KeyRelease event -# $zinc->bind($g, '' => [\&raise, $g]); - -#########################################################################" -# Definition of all callbacks - -sub updateLabel { - my ($group) = @_; - my $priority = $zinc->itemcget($group, -priority); - # we get the text item from this group: - my $textitem = $zinc->find('withtype', 'text', ".$group."); - $zinc->itemconfigure($textitem, -text => "pri=$priority"); -} - -sub setPriorrity { - my ($zinc, $priority) = @_; - my $item = $zinc->find('withtag', 'current'); - return unless $item; - $zinc->itemconfigure ($item, -priority => $priority); - &updateLabel($item); -} - - -# Callback to lower a small group of a rectangle and a text -sub lower { - my ($zinc) = @_; - # to get the item under the cursor! - my $item = $zinc->find('withtag', 'current'); - return unless $item; - $zinc->lower($item); - &updateLabel($item); -} - -# Callback to raise a small group of a rectangle and a text -sub raise { - my ($zinc) = @_; - # to get the item under the cursor! - my $item = $zinc->find('withtag', 'current'); - return unless $item; - $zinc->raise($item); - &updateLabel($item); -} - -# Callback to raise the group of groups of a rectangle and a text -sub lowerGroup { - my ($zinc) = @_; - # to get the item under the cursor! - my $item = $zinc->find('withtag', 'current'); - return unless $item; - my $coloredGroup = $zinc->group($item); - $zinc->lower($coloredGroup); -} - -# Callback to raise the group of groups of a rectangle and a text -sub raiseGroup { - my ($zinc) = @_; - # to get the item under the cursor! - my $item = $zinc->find('withtag', 'current'); - return unless $item; - my $coloredGroup = $zinc->group($item); - $zinc->raise($coloredGroup); - &updateLabel($item); -} - -# Callback to change the group of groups of a rectangle and a text -sub toggleItemGroup { - my ($zinc) = @_; - # to get the item under the cursor! - my $item = $zinc->find('withtag', 'current'); - return unless $item; - my $newgroup; - if ($group1 == $zinc->group($item)) { - $newgroup = $group2; - } - else { - $newgroup = $group1; - } - - $zinc->chggroup($item,$newgroup,1); ## the lats argument is true for mainting $item' position - &updateLabel($item); -} - -# callback for starting a drag -my ($x_orig, $y_orig); -sub press { - my ($zinc, $group, $action) = @_; - my $ev = $zinc->XEvent(); - $x_orig = $ev->x; - $y_orig = $ev->y; - $zinc->Tk::bind('', [$action, $group]); -} - -# Callback for moving a small group of a rectangle and a text -sub motion { - my ($zinc, $group) = @_; - my $ev = $zinc->XEvent(); - my $x = $ev->x; - my $y = $ev->y; - - $zinc->translate($group, $x-$x_orig, $y-$y_orig); - $x_orig = $x; - $y_orig = $y; -} - -# Callback for moving a group of groups of a rectangle and a text -sub groupMotion { - my ($zinc, $group) = @_; - my $ev = $zinc->XEvent(); - my $x = $ev->x; - my $y = $ev->y; - - my $coloredGroup = $zinc->group($group); - $zinc->translate($coloredGroup, $x-$x_orig, $y-$y_orig); - $x_orig = $x; - $y_orig = $y; -} - -# Callback when releasing the mouse button. It removes any motion callback -sub release { - my ($zinc) = @_; - $zinc->Tk::bind('', ''); -} - - -Tk::MainLoop(); - - -1; diff --git a/Perl/demos/Tk/demos/zinc_lib/icon_zoom_resize.pl b/Perl/demos/Tk/demos/zinc_lib/icon_zoom_resize.pl deleted file mode 100644 index 1274ffc..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/icon_zoom_resize.pl +++ /dev/null @@ -1,157 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# this simple demo has been developped by C. Mertz - -package icon_zoom__resize; # for avoiding symbol re-use between different demos - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; - - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-140-*-*-*-*-*-*'; -my $mw = MainWindow->new(); -my $text = $mw->Scrolled(qw/Text -relief sunken -borderwidth 2 -setgrid true - -height 7 -scrollbars ''/); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', - 'This demo needs openGL for rescaling/rotating the icon - You can transform this earth gif image with your mouse: - Drag-Button 1 for zooming the earth, - Drag-Button 2 for rotating the earth, - Drag-Button 3 for moving the earth, - Shift-Drag-Button 1 for modifying the earth transparency' - ); - -my $zinc = $mw->Zinc(-width => 350, -height => 250, - -render => 1, - -font => "10x20", # usually fonts are sets in resources - # but for this example it is set in the code! - -borderwidth => 3, -relief => 'sunken', - )->pack; - -my $earth_group = $zinc->add('group', 1, ); - -# the following image is included in Perl/Tk distrib -my $image = $zinc->Photo('earth.gif', -file => Tk->findINC('demos/images/earth.gif')); - -my $earth = $zinc->add('icon', $earth_group, - -image => $image, - -composescale => 1, - -composerotation => 1, - ); -$zinc->add('text', $earth_group, - -position => [30,30], -# -connecteditem => $earth, - -text => "try to zoom/resize the earth!\nWorks even without openGL!!", - -color => "white", - -composescale => 1, - -composerotation => 1, - ); - -$zinc->Tk::bind('', [\&press, \&zoom]); -$zinc->Tk::bind('', [\&release]); - -$zinc->Tk::bind('', [\&press, \&rotate]); -$zinc->Tk::bind('', [\&release]); - -$zinc->Tk::bind('', [\&press, \&motion]); -$zinc->Tk::bind('', [\&release]); - - -$zinc->Tk::bind('', [\&press, \&modifyAlpha]); -$zinc->Tk::bind('', [\&release]); - - - -# -# Controls for the window transform. -# -my ($cur_x, $cur_y, $cur_angle); -sub press { - my ($zinc, $action) = @_; - my $ev = $zinc->XEvent(); - $cur_x = $ev->x; - $cur_y = $ev->y; - $cur_angle = atan2($cur_y, $cur_x); - $zinc->Tk::bind('', [$action]); -} - -sub modifyAlpha { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $xrate = $lx / $zinc->cget(-width); - - $xrate = 0 if $xrate < 0; - $xrate = 1 if $xrate > 1; - - my $alpha = $xrate * 100; - - $zinc->itemconfigure($earth_group, -alpha => $alpha); -} - - -sub motion { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my @res; - - @res = $zinc->transform($earth_group, [$lx, $ly, $cur_x, $cur_y]); - $zinc->translate($earth_group, $res[0] - $res[2], $res[1] - $res[3]); - $cur_x = $lx; - $cur_y = $ly; -} - -sub zoom { - my ($zinc, $self) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my $maxx; - my $maxy; - my $sx; - my $sy; - - if ($lx > $cur_x) { - $maxx = $lx; - } else { - $maxx = $cur_x; - } - if ($ly > $cur_y) { - $maxy = $ly - } else { - $maxy = $cur_y; - } - return if ($maxx == 0 || $maxy == 0); - $sx = 1.0 + ($lx - $cur_x)/$maxx; - $sy = 1.0 + ($ly - $cur_y)/$maxy; - $cur_x = $lx; - $cur_y = $ly; - $zinc->scale($earth_group, $sx, $sy); -} - -sub rotate { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my $langle; - - $langle = atan2($ly, $lx); - $zinc->rotate($earth_group, -($langle - $cur_angle)); - $cur_angle = $langle; -} - -sub release { - my ($zinc) = @_; - $zinc->Tk::bind('', ''); -} - -Tk::MainLoop; diff --git a/Perl/demos/Tk/demos/zinc_lib/items.pl b/Perl/demos/Tk/demos/zinc_lib/items.pl deleted file mode 100644 index d092924..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/items.pl +++ /dev/null @@ -1,187 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# these simple samples have been developped by C. Mertz mertz@cena.fr - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); -my $zinc = $mw->Scrolled('Zinc', -width => 700, -height => 600, - -font => '10x20', -borderwidth => 3, - -relief => 'sunken', -scrollbars => 'se', - -scrollregion => [-100, 0, 1000, 1000]); -$zinc->pack(-expand => 'yes', -fill => 'both'); - -$zinc->add('rectangle', 1, [10,10, 100, 50], -fillcolor => "green", -filled => 1, - -linewidth => 10, -relief => "roundridge", -linecolor => "darkgreen"); - - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "A filled rectangle with a \"roundridge\" relief border of 10 pixels.", - -anchor => 'nw', - -position => [120, 20]); - - -my $labelformat = "x82x60+0+0 x60a0^0^0 x32a0^0>1 a0a0>2>1 x32a0>3>1 a0a0^0>2"; - -my $x=20; -my $y=120; -my $track=$zinc->add('track', 1, 6, # 6 is the number of fields in the flightlabel - -labelformat => $labelformat, - -position => [$x, $y], - -speedvector => [40, -10], - -speedvectormark => 1, # currently works only with openGL - -speedvectorticks => 1, # currently works only with openGL - ); -# moving the track, to display past positions -foreach my $i (0..5) { $zinc->coords("$track",[$x+$i*10,$y-$i*2]); } - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "A flight track for a radar display. (A waypoint looks similar,\n". - "but has no speedvector neither past positions)", - -anchor => 'nw', - -position => [200, 80], - ); - -$zinc->itemconfigure($track, 0, - -filled => 0, - -bordercolor => 'DarkGreen', - -border => "contour", - ); -$zinc->itemconfigure($track, 1, - -filled => 1, - -backcolor => 'gray60', - -text => "AFR001"); -$zinc->itemconfigure($track, 2, - -filled => 0, - -backcolor => 'gray65', - -text => "360"); -$zinc->itemconfigure($track, 3, - -filled => 0, - -backcolor => 'gray65', - -text => "/"); -$zinc->itemconfigure($track, 4, - -filled => 0, - -backcolor => 'gray65', - -text => "410"); -$zinc->itemconfigure($track, 5, - -filled => 0, - -backcolor => 'gray65', - -text => "Beacon"); - - - - - -$zinc->add('arc', 1, [150, 140, 450, 240], -fillcolor => "gray20", - -filled => 0, -linewidth => 1, - -startangle => 45, -extent => 270); -$zinc->add('arc', 1, [260, 150, 340, 230], -fillcolor => "gray20", - -filled => 0, -linewidth => 1, - -startangle => 45, -extent => 270, - -pieslice => 1, -closed => 1, - -linestyle => 'mixed', -linewidth => 3, - ); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "Two arcs, starting at 45° with an extent of 270°.", - -anchor => 'nw', - -position => [320, 180]); - - -$zinc->add('curve', 1, [10, 324, 24, 300, 45, 432, 247, 356, 128, 401], - -filled => 0, -relief => 'roundgroove', - # -linewidth => 10, ## BUG with zinc 3.2.3g - ); -$zinc->add('text', 1, - -font => $defaultfont, - -text => "An open curve.", - -anchor => 'nw', - -position => [50, 350]); - - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "A waypoint", - -anchor => 'nw', - -position => [10, 480], - ); -my $waypoint = $zinc->add('waypoint', 1, 6, -position => [100,520], - -labelformat => $labelformat, - -symbol => "AtcSymbol2", - -labeldistance => 30); - -foreach my $fieldId (1..5) { - $zinc->itemconfigure($waypoint, $fieldId, - -filled => 0, - -bordercolor => 'DarkGreen', - -border => "contour", # does not work with openGL (zinc-perl v3.2.3e) - -text => "field$fieldId", - ); -} - - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "3 tabulars of 2 fields,\nattached together.", - -anchor => 'nw', - -position => [510, 380], - ); - -my $labelformat2 = "x72x40 x72a0^0^0 x34a0^0>1"; - -my $tabular1 = $zinc->add('tabular', 1, 6, -position => [570,250], - -labelformat => $labelformat2, - ); -my $tabular2 = $zinc->add('tabular', 1, 6, -connecteditem => $tabular1, - -labelformat => $labelformat2, - ); -my $tabular3 = $zinc->add('tabular', 1, 6, -connecteditem => $tabular2, - -labelformat => $labelformat2, - ); -my $count=1; -foreach my $tab ($tabular1, $tabular2, $tabular3) { - $zinc->itemconfigure($tab, 1, -filled => 0, - -bordercolor => 'DarkGreen', - -border => "contour", -text => "tabular", - ); - $zinc->itemconfigure($tab, 2, -filled => 0, - -bordercolor => 'DarkGreen', - -border => "contour", -text => "n°$count", - ); - $count++; -} - - -$zinc->add('reticle', 1, -position => [530,550], - -firstradius => 20, -numcircles => 6, - -period => 2, -stepsize => 20, - -brightlinestyle => 'dashed', -brightlinecolor => 'darkred', - ); - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "a reticle of 6 circles.", - -anchor => 'nw', - -position => [530, 540]); - - - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "maps, triangles and groups items\nare not demonstrated here.", - -anchor => 'nw', - -position => [10, 550]); - - - -MainLoop; - diff --git a/Perl/demos/Tk/demos/zinc_lib/labelformat.pl b/Perl/demos/Tk/demos/zinc_lib/labelformat.pl deleted file mode 100644 index 465eb07..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/labelformat.pl +++ /dev/null @@ -1,111 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# This simple demo has been developped by C. Mertz - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; - -my $mw = MainWindow->new(); - - -########################################### -# Text zone -########################################### - -my $text = $mw->Text(-relief => 'sunken', -borderwidth => 2, - -height => 4); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', -'This toy-appli demonstrates the use of labelformat for tabular items. -The fieldPos (please, refer to the "labelformat type" description -in the "Zinc reference manual") of each field as described in -the labelformat is displayed inside the field.'); - - -########################################### -# Zinc -########################################## -my $zinc = $mw->Zinc(-width => 600, -height => 500, - -font => "10x20", - -borderwidth => 3, -relief => 'sunken', - )->pack; - -########################################### -# Tabulars -########################################### - -### first labelformat and tabular -my $labelformat1 = "300x300 x100x20+0+0 x100x20+100+0 x100x20+0+20 x100x20+100+20 x100x20+50+55"; - -my $tabular1 = $zinc->add('tabular',1, 5, - -position => [10,10], - -labelformat => $labelformat1, - ); - -&setLabelContent ($tabular1,$labelformat1); - -$zinc->add('text', 1, -position => [10,100], -text => - "All fields positions -are given in pixels"); - - -### second labelformat and tabular -my $labelformat2 = "300x300 x110x20+100+30 x80x20<0<0 x80x20<0>0 x80x20>0>0 x80x20>0<0"; - -my $tabular2 = $zinc->add('tabular',1, 5, - -position => [270,10], - -labelformat => $labelformat2, - ); -&setLabelContent ($tabular2,$labelformat2); - -$zinc->add('text', 1, -position => [260,100], -text => - "All fields positions are given -relatively to field 0. -They are either on the left/right -and up/down the field 0."); - - -### third labelformat and tabular -my $labelformat3 = "400x300 x200x70+100+70 x80x26^0<0 x80x26^0>0 x80x29\$0\$0 x80x32\$0^0 x90x20\<1^1 x90x20<2\$2 x90x20^4<4 x90x20^3>3"; - -my $tabular3 = $zinc->add('tabular',1, 9, - -position => [150,180], - -labelformat => $labelformat3, - ); -&setLabelContent ($tabular3,$labelformat3); - -$zinc->add('text', 1, -position => [40,360], -text => - "Fields 1-4 are positionned relatively to field 0. -Field 5 is positionned relatively to field 1, -Field 6 is positionned relatively to field 2..." -); - - -### this function displays in each field, the corresponding -### part of the labelformat -sub setLabelContent { - my ($item,$labelformat) = @_; - - my @fieldsSpec = split (/ / , $labelformat); - shift @fieldsSpec; - - my $i=0; - foreach my $fieldSpec (@fieldsSpec) { - my ($posSpec) = $fieldSpec =~ /^.\d+.\d+(.*)/ ; -# print "$fieldSpec\t$i\t$posSpec\n"; - $zinc->itemconfigure ($item,$i, - -text => "$i: $posSpec", - -border => "contour", - ); - $i++; - } -} - - - -MainLoop; diff --git a/Perl/demos/Tk/demos/zinc_lib/lines.pl b/Perl/demos/Tk/demos/zinc_lib/lines.pl deleted file mode 100644 index 5469404..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/lines.pl +++ /dev/null @@ -1,96 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# these simple samples have been developped by C. Mertz mertz@cena.fr - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); -my $zinc = $mw->Zinc(-width => 700, -height => 600, - -font => "10x20", # usually fonts are sets in resources - # but for this example it is set in the code! - -borderwidth => 3, -relief => 'sunken', - )->pack; - -$zinc->add('text', 1, - -font => $defaultfont, - -text => "A set of lines with different styles of lines and termination\n". - "NB: some attributes such as line styles are not necessarily\n". - " available with an openGL rendering system" , - -anchor => 'nw', - -position => [20, 20]); - -$zinc-> add('curve', 1, [20, 100, 320, 100]); # default options -$zinc-> add('curve', 1, [20, 120, 320, 120], - -linewidth => 20, - ); -$zinc-> add('curve', 1, [20, 160, 320, 160], - -linewidth => 20, - -capstyle => "butt", - ); -$zinc-> add('curve', 1, [20, 200, 320, 200], - -linewidth => 20, - -capstyle => "projecting", - ); -$zinc-> add('curve', 1, [20, 240, 320, 240], - -linewidth => 20, - -linepattern => "AlphaStipple7", - -linecolor => "red", - ); - -# right column -$zinc-> add('curve', 1, [340, 100, 680, 100], - -firstend => [10, 10, 10], - -lastend => [10, 25, 45], - ); -$zinc-> add('curve', 1, [340, 140, 680, 140], - -linewidth => 2, - -linestyle => 'dashed', - ); -$zinc-> add('curve', 1, [340, 180, 680, 180], - -linewidth => 4, - -linestyle => 'mixed', - ); -$zinc-> add('curve', 1, [340, 220, 680, 220], - -linewidth => 2, - -linestyle => 'dotted', - ); - -$zinc->add('curve', 1, [20, 300, 140, 360, 320, 300, 180, 260], - -closed => 1, - -filled => 1, - -fillpattern => "Tk", - -fillcolor => "grey60", - -linecolor => "red", - -marker => "AtcSymbol7", - -markercolor => "blue", - - ); - - -$zinc->add('curve', 1, [340, 300, 440, 360, 620, 300, 480, 260], - -closed => 1, - -linewidth => 10, - -joinstyle => "miter", #"round", # "bevel" | "miter" - -linecolor => "red", - ); -$zinc->add('curve', 1, [400, 300, 440, 330, 560, 300, 480, 280], - -closed => 1, - -linewidth => 10, - -joinstyle => "round", # "bevel" | "miter" - -tile => Tk::findINC("Xcamel.gif"), - -fillcolor => "grey60", - -filled => 1, - -linecolor => "red", - ); - -# -tile => Tk::findINC("Xcamel.gif"), - -MainLoop; - - diff --git a/Perl/demos/Tk/demos/zinc_lib/mapinfo.pl b/Perl/demos/Tk/demos/zinc_lib/mapinfo.pl deleted file mode 100644 index f6dc46e..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/mapinfo.pl +++ /dev/null @@ -1,130 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# This simple demo has been developped by C. Schlienger - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; - - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); - -########################################### -# Text zone -########################################### - -my $text = $mw->Text(-relief => 'sunken', -borderwidth => 2, - -height => 4); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', - 'This toy-appli shows zoom actions on map item. -The following operations are possible: - Click "-" to zoom out - Click "+" to zoom in ' ); - -########################################### -# Zinc -########################################### -my $zinc_width=600; -my $zinc_height=500; -my $zinc = $mw->Zinc(-width => $zinc_width, -height => $zinc_height, - -font => "10x20", - -borderwidth => 3, -relief => 'sunken', - )->pack; - -########################################### -# Waypoints and sector -########################################### - -my $mapinfo=$mw->mapinfo("mapinfo","create"); #creation of mapinfo - -#-------------------------------- -# Waypoints -#-------------------------------- -$mw->mapinfo("mapinfo","add","symbol",200,100,0); -$mw->mapinfo("mapinfo","add","symbol",300,150,0); -$mw->mapinfo("mapinfo","add","symbol",400,50,0); -$mw->mapinfo("mapinfo","add","symbol",350,450,0); -$mw->mapinfo("mapinfo","add","symbol",300,250,0); -$mw->mapinfo("mapinfo","add","symbol",170,240,0); -$mw->mapinfo("mapinfo","add","symbol",550,200,0); - -#-------------------------------- -# Waypoints names -#-------------------------------- -$mw->mapinfo("mapinfo","add","text","normal","simple",170,100,"DO"); -$mw->mapinfo("mapinfo","add","text","normal","simple",270,160,"RE"); -$mw->mapinfo("mapinfo","add","text","normal","simple",410,50,"MI"); -$mw->mapinfo("mapinfo","add","text","normal","simple",345,470,"FA"); -$mw->mapinfo("mapinfo","add","text","normal","simple",280,265,"SOL"); -$mw->mapinfo("mapinfo","add","text","normal","simple",150,240,"LA"); -$mw->mapinfo("mapinfo","add","text","normal","simple",555,200,"SI"); - -#-------------------------------- -# Routes -#-------------------------------- - -$mw->mapinfo("mapinfo","add","line","simple",1,200,100,300,150); -$mw->mapinfo("mapinfo","add","line","simple",1,300,150,400,50); -$mw->mapinfo("mapinfo","add","line","simple",1,300,150,350,450); -$mw->mapinfo("mapinfo","add","line","simple",1,300,250,170,240); -$mw->mapinfo("mapinfo","add","line","simple",1,300,250,550,200); - -#-------------------------------- -# Sectors -#--------------------------------- -$mw->mapinfo("mapinfo","add","line","simple",1,300,0,400,50); -$mw->mapinfo("mapinfo","add","line","simple",1,400,50,500,100); -$mw->mapinfo("mapinfo","add","line","simple",1,500,100,550,200); -$mw->mapinfo("mapinfo","add","line","simple",1,550,200,550,400); -$mw->mapinfo("mapinfo","add","line","simple",1,550,400,350,450); -$mw->mapinfo("mapinfo","add","line","simple",1,350,450,170,240); -$mw->mapinfo("mapinfo","add","line","simple",1,170,240,200,100); -$mw->mapinfo("mapinfo","add","line","simple",1,200,100,300,0); - -#-------------------------------- -# Sectors -#--------------------------------- -my $gpe = $zinc ->add('group',1); -my $map = $zinc ->add('map',$gpe,#creation of the map object which has 'mapinfo' information - -mapinfo=>"mapinfo", - -symbols=>['AtcSymbol15']); - - -################################################### -# control panel -################################################### -my $rc = $mw->Frame()->pack(); - -#the reference of the scale function is top-left corner of the zinc object -#so we first translate the group to zoom in order to put its center on top-left corner -#change the scale of the group -#translate the group to put it back at the center of the zinc object - -my $minus=$rc->Button(-width => 2, - -height => 2, - -text => '-', - -command=>sub{ - $zinc->translate($gpe,-$zinc_width/2,-$zinc_height/2); - $zinc->scale($gpe,0.8,0.8); - $zinc->translate($gpe, $zinc_width/2,$zinc_height/2); - })->pack(-side=>'left'); - - -my $plus=$rc->Button(-width => 2, - -height => 2, - -text => '+', - -command=>sub{ - $zinc->translate($gpe, -$zinc_width/2,-$zinc_height/2); - $zinc->scale($gpe,1.2,1.2); - $zinc->translate($gpe,$zinc_width/2,$zinc_height/2); - })->pack(-side => 'right'); - - - -MainLoop; diff --git a/Perl/demos/Tk/demos/zinc_lib/path_tags.pl b/Perl/demos/Tk/demos/zinc_lib/path_tags.pl deleted file mode 100644 index 30272d8..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/path_tags.pl +++ /dev/null @@ -1,357 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# this pathtatg demo have been developped by C. Mertz mertz@cena.fr -# with the help of Daniel Etienne etienne@cena.fr - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; - -#This demo only works with Tk::Zinc > "3.2.5b"; - -## this demo demonstrates the use of path tags to address one or more items -## belonging to a hierarchy of groups. -## This hierarchy is described just below, gr_xxx designates a group -## (with a tag xxx) and i_yyy designates an non-group item (with a tag yyy). - -# gr_top --- gr_a --- gr_aa --- gr_aaa --- gr_aaaa --- i_aaaaa -# | | | |-- i_aaab |-- i_aaaab -# | | -- i_aab -# | |-- i_ab -# | | -# | ---gr_ac --- i_aca -# | | -# |-- i_b --- i_acb -# | -# --- gr_c --- gr_ca --- i_caa -# | | -# | --- i_cab -# |-- i_cb -# | -# ---gr_cc --- i_cca -# | -# --- i_ccb -#the same objects are cloned and put in an other hierarchy where -#gr_top is replaced by gr_other_top - -my $defaultForecolor = "grey80"; -my $selectedColor = "yellow"; -my $mw = MainWindow->new(); - -########################################### -# Text zone -########################################### - -my $text = $mw->Text(-relief => 'sunken', -borderwidth => 2, - -height => 5, -font => "10x20"); -$text->pack(-expand => 'yes', -fill => 'both'); - -$text->insert('0.0', -'This represents a group hierarchy: - - groups are represented by a rectangle and an underlined title. - - non-group items are represented by a text. -Select a pathTag or a tag with one of the radio-button -or experiment your own tags in the input field'); - -########################################### -# Zinc creation -########################################### - -my $zinc = $mw->Zinc(-width => 850, -height => 360, -font => "10x20", - -borderwidth => 0, -backcolor => "black", - -forecolor => $defaultForecolor, - )->pack; - -########################################### -# Creation of a bunch of radiobutton and a text input -########################################### - -my $tagsfm = $mw->Frame()->pack(); -my $pathtag; - -my @pl = qw/-side left -expand 1 -padx .5c -pady .2c/; -my $left = $tagsfm->Frame->pack(@pl); -my $middle = $tagsfm->Frame->pack(@pl); -my $right = $tagsfm->Frame->pack(@pl); -my $rtop = $right->Frame->pack(-side => 'top'); -my $rbottom = $right->Frame->pack(-side => 'top'); -my $rbot_left = $rbottom->Frame->pack(-side => 'left'); -my $rbot_right = $rbottom->Frame->pack(-side => 'left'); - -my $resultfm = $mw->Frame()->pack(); -$resultfm->Label(-font => "10x20", - -relief => 'flat', - -text => 'explanation:', - )->pack(-side => 'left'); -my $explan_txt = $resultfm->Label(-font => "10x20", - -relief => 'flat', - -width => 70, - -height => 3.5, - -text => '...', - -justify => 'left', - -wraplength => '16c', - )->pack(-side => 'left'); - - -@pl = qw/-side top -pady 2 -anchor w/; -my @tags_explan; -@tags_explan = ("top" => "a simple tag for the top group", - ".top" => "all items in the root group with the tag 'top'", - ".top." => "direct children of a group in the root group with the tag 'top'", - ".top*" => "descendance of ONE group in the root group with the tag 'top'", - ".top*cca" => "items with a tag 'cca' in ONE direct group of root group with tag 'top'", - ".5." => "direct content of THE group with id 5"); -while (@tags_explan) { - my $tag = shift @tags_explan; - my $explan = shift @tags_explan; - $left->Radiobutton(-text => $tag, - -font => "10x20", - -command => sub { &displayPathtag ($explan)}, - -variable => \$pathtag, - -relief => 'flat', - -value => $tag, - )->pack(@pl); -} -@tags_explan = (".top*aa" => "items with a tag 'aa' in a direct group of root group with tag 'top'", - ".top*aa." => "direct children of ONE group with a tag 'aa', descending from a direct group of root group with tag 'top'", - ".top*aa*" => "descendance of ONE group with a tag 'aa', descending from a direct group of root group with tag 'top'", - ".top.a" => "items with a tag 'a' in a direct group of root group with tag 'top'", - ".top.a." => "direct children of ONE group with a tag 'a' in a direct group of root group with tag 'top'", - ".5*" => "descendance of THE group with id 5", - ); -while (@tags_explan) { - my $tag = shift @tags_explan; - my $explan = shift @tags_explan; - $middle->Radiobutton(-text => $tag, - -font => "10x20", - -command => sub { &displayPathtag ($explan)}, - -variable => \$pathtag, - -relief => 'flat', - -value => $tag, - )->pack(@pl); -} - - -$rtop->Label(-font => "10x20", - -relief => 'flat', - -text => 'your own tag :', - )->pack(-side => 'left'); -$rtop->Entry(-font => "10x20", -width => 15) - ->pack(-side => 'left')->bind('', sub {$pathtag = $_[0]->get(); - &displayPathtag("sorry, I am not smart enough to explain your pathTag ;-)")}); - - -@tags_explan = (".top*aa*aaa" => "all items with a tag 'aaa' descending from ONE group with a tag 'aa' descending from ONE group with a tag 'top' child of the root group", - ".top*aa*aaa." => "children of ONE group with a tag 'aaa' descending from ONE group with a tag 'aa' descending from ONE group with a tag 'top' child of the root group", - ".top*aa*aaa*" => "descendance of ONE group with a tag 'aaa' descending from ONE group with a tag 'aa' descending from ONE group with a tag 'top' child of the root group", - ".other_top*aa*" => "descendance of ONE group with a tag 'aa' descending from ONE group with a tag 'other_top' child of the root group", - ".5*ca*" => "descendance of ONE group with a tag 'ca' descending from THE group with id 5", - ); -while (@tags_explan) { - my $tag = shift @tags_explan; - my $explan = shift @tags_explan; - $rbot_left->Radiobutton(-text => $tag, - -font => "10x20", - -command => sub { &displayPathtag ($explan)}, - -variable => \$pathtag, - -relief => 'flat', - -value => $tag, - )->pack(@pl); -} - -@tags_explan = ("*aa*aaaa" => "all items with a tag 'aaaa' descending from a group with a tag 'aa'", - "*aaa" => "all items with a tag 'aaa'", - "aa || ca" => "items with tag 'aa' or tag 'ca'", - "none" => "no items, as none has the tag 'none'", - "all" => "all items", - ); -while (@tags_explan) { - my $tag = shift @tags_explan; - my $explan = shift @tags_explan; - $rbot_right->Radiobutton(-text => $tag, - -font => "10x20", - -command => sub { &displayPathtag ($explan)}, - -command => \&displayPathtag, - -variable => \$pathtag, - -relief => 'flat', - -value => $tag, - )->pack(@pl); -} - -# creating the item hierarchy -$zinc ->add('group', 1, -tags => ['top']); -&createSubHierarchy ('top'); - -# creating a parallel hierarchy -$zinc ->add('group', 1, -tags => ['other_top']); -&createSubHierarchy ('other_top'); - -### Here we create the genuine hierarchy of groups and items -### Later we will create graphical objects to display groups -sub createSubHierarchy { - my ($gr) = @_; - $zinc->add('group', $gr, -tags => ['a']); - $zinc->add('text', $gr, -tags => ['b', 'text'], -text => 'b', - -position => [270,150]); - $zinc->add('group', $gr, -tags => ['c']); - - $zinc->add('group', 'a', -tags => ['aa']); - $zinc->add('text', 'a', -tags => ['ab', 'text'], -text => 'ab' - , -position => [60,220]); - $zinc->add('group', 'a', -tags => ['ac']); - - $zinc->add('group', 'aa', -tags => ['aaa']); - $zinc->add('text', 'aa', -tags => ['aab', 'text'], -text => 'aab', - -position => [90,190]); - $zinc->add('group', 'aaa', -tags => ['aaaa']); - $zinc->add('text', 'aaaa', -tags => ['aaaaa', 'text'], -text => 'aaaaa', - -position => [150,110]); - $zinc->add('text', 'aaaa', -tags => ['aaaab', 'text'], -text => 'aaaab', - -position => [150,130]); - $zinc->add('text', 'aaa', -tags => ['aaab', 'text'], -text => 'aaab', - -position => [120,160]); - - $zinc->add('text', 'ac', -tags => ['aca'], -text => 'aca', - -position => [90,260]); - $zinc->add('text', 'ac', -tags => ['acb', 'text'], -text => 'acb', - -position => [90,290]); - - $zinc->add('group', 'c', -tags => ['ca']); - $zinc->add('text', 'c', -tags => ['cb', 'text'], -text => 'cb', - -position => [330,160]); - $zinc->add('group', 'c', -tags => ['cc']); - - $zinc->add('text', 'ca', -tags => ['caa', 'text'], -text => 'caa', - -position => [360,110]); - $zinc->add('text', 'ca', -tags => ['cab', 'text'], -text => 'cab', - -position => [360,130]); - - $zinc->add('text', 'cc', -tags => ['cca', 'text'], -text => 'cca', - -position => [360,200]); - $zinc->add('text', 'cc', -tags => ['ccb', 'text'], -text => 'ccb', - -position => [360,220]); -} - -## modifying the priority so that all rectangles and text will be visible -map { $_, $zinc->itemconfigure($_,-priority => 20)} ($zinc->find('withtype', 'text', ".top*")); -map { $_, $zinc->itemconfigure($_,-priority => 20)} ($zinc->find('withtype', 'text', ".other_top*")); -map { $_, $zinc->itemconfigure($_,-priority => 20)} ($zinc->find('withtype', 'group', ".top*")); -map { $_, $zinc->itemconfigure($_,-priority => 20)} ($zinc->find('withtype', 'group', ".other_top*")); - -# converts a list of items ids in a list of sorted tags (the first tag of each item) -sub items2tags { - my @items = @_; - my @selected_tags; - foreach my $item (@items) { - my @tags = $zinc->itemcget ($item, -tags); - next if $tags[0] =~ /frame|title/ ; # to remove group titles frame - push @selected_tags, $tags[0]; - } - return sort @selected_tags; -} - -### drawing : -#### a rectangle item for showing the bounding box of each group, -### a text item for the group name (i.e. its first tag) - -## backgrounds used to fill rectangles representing groups -my @backgrounds = qw(grey25 grey35 grey43 grey50 grey55); - -sub drawHierarchy { - my ($group,$level) = @_; - my @tags = $zinc->gettags($group); -# print "level=$level (", $tags[0],")\n"; - foreach my $g ($zinc->find('withtype', 'group', ".$group.")) { - &drawHierarchy ($g,$level+1); - } - my ($x,$y,$x2,$y2) = $zinc->bbox($group); - $zinc->add('text',$group, -position => [$x-5,$y-4], - -text => $tags[0], -anchor => "w", -alignment => "left", - -underlined => 1, - -priority => 20, - -tags => ["title_".$tags[0], 'group_title'], - ); - ($x,$y,$x2,$y2) = $zinc->bbox($group); - if (defined $x) { - my $background = $backgrounds[$level]; - $zinc->add('rectangle', $group, [$x+0,$y+5,$x2+5,$y2+2], - -filled => 1, - -fillcolor => $background, - -priority => $level, - -tags => ["frame_".$tags[0], 'group_frame'], - ); - } else { - print "undefined bbox for $group : @tags\n"; - } -} - -### this sub extracts out of groups both text and frame representing -### each group. This is necessary to avoid unexpected selection of -### rectangles and titles inside groups -sub extractTextAndFrames { - foreach my $group_title ($zinc->find('withtag', 'group_title || group_frame')) { - my @ancestors = $zinc->find('ancestor',$group_title); -# print "$group_title, @ancestors\n"; - my $grandFather = $ancestors[1]; - $zinc->chggroup($group_title,$grandFather,1); - } -} - -## this sub modifies the color/line color of texts and rectangles -## representing selected items. -sub displayPathtag { -# print "var=@_ $pathtag\n"; - my $explanation = shift; - my @selected = $zinc->find('withtag', $pathtag); - my @tags = &items2tags(@selected); -# print "selected: @tags\n"; - $explan_txt->configure(-text => $explanation ? "$explanation\n" : ""); - - ## unselecting all items - foreach my $item ($zinc->find('withtype', 'text')) { - $zinc->itemconfigure($item, -color => $defaultForecolor); - } - foreach my $item ($zinc->find('withtype', 'rectangle')) { - $zinc->itemconfigure($item, -linecolor => $defaultForecolor); - } - - ## highlighting selected items - foreach my $item (@selected) { - my $type = $zinc->type($item); -# print $item, " ", $zinc->type($item), " ", join (",",$zinc->gettags($item)), "\n"; - if ($type eq 'text') { - $zinc->itemconfigure($item, -color => $selectedColor); - } elsif ($type eq 'rectangle') { - $zinc->itemconfigure($item, -linecolor => $selectedColor); - } elsif ($type eq 'group') { - my $tag = ($zinc->gettags($item))[0]; - ## as there is 2 // hierachy, we must refine the tag used - ## to restrict to the proper hierarchy - ## NB: this is due to differences between the group hierarchy - ## and the graphical object hierarchy used for this demo - if ($zinc->find('ancestors',$item,'top')) { - $zinc->itemconfigure(".top*frame_$tag", -linecolor => $selectedColor); - $zinc->itemconfigure(".top*title_$tag", -color => $selectedColor); - } elsif ($zinc->find('ancestors',$item,'other_top')) { - $zinc->itemconfigure(".other_top*frame_$tag", -linecolor => $selectedColor); - $zinc->itemconfigure(".other_top*title_$tag", -color => $selectedColor); - } else { - $zinc->itemconfigure("frame_$tag", -linecolor => $selectedColor); - $zinc->itemconfigure("title_$tag", -color => $selectedColor); - } - } - } -} - -&drawHierarchy('top',0); -&drawHierarchy('other_top',0); -$zinc->translate('other_top', 400,0); -&extractTextAndFrames; - - - -MainLoop; - diff --git a/Perl/demos/Tk/demos/zinc_lib/rotation.pl b/Perl/demos/Tk/demos/zinc_lib/rotation.pl deleted file mode 100644 index c5549bf..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/rotation.pl +++ /dev/null @@ -1,124 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# This simple demo has been developped by C. Schlienger - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - - -use Tk; -use Tk::Zinc; -use strict; -use constant; - -my constant $PI=3.1416; - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); - - -########################################### -# Text zone -########################################### - -my $text = $mw->Text(-relief => 'sunken', -borderwidth => 2, -height => 4); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', - 'This toy-appli shows rotations on waypoint items. -The following operations are possible: - Click "<-" for negative rotation - Click "->" for positive rotation' ); - - -########################################### -# Zinc -########################################### -my $zinc_width=600; -my $zinc_height=500; -my $zinc = $mw->Zinc(-width => $zinc_width, -height => $zinc_height, - -font => "10x20", - -borderwidth => 3, -relief => 'sunken', - )->pack; - -########################################### -# Waypoints -########################################### - -my $wp_group = $zinc->add('group', 1, -visible => 1); - -my $p1=[200, 200]; -my $wp1 = $zinc->add('waypoint',$wp_group, 1, - -position => $p1, - -connectioncolor => 'green', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldx=>'-20' - ); -$zinc->itemconfigure($wp1, 0, - -text => "DO", - ); - -my $p2=[300, 300]; -my $wp2 = $zinc->add('waypoint',$wp_group, 1, - -position => $p2, - -connecteditem => $wp1, - -connectioncolor => 'blue', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldx=>'-20', - #-labeldy=>'30' - ); - -$zinc->itemconfigure($wp2, 0, - -text => "RE", - ); - -my $p3=[400, 150]; -my $wp3 = $zinc->add('waypoint', $wp_group, 2, - -position => $p3, - -connecteditem => $wp2, - -connectioncolor => 'blue', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldx=>'20', - -labeldy=>'+10' - ); -$zinc->itemconfigure($wp3, 0, - -text => "MI", - ); - -################################################### -# control panel -################################################### -my $rc = $mw->Frame()->pack(); - -my $left=$rc->Button(-width => 2, - -height => 2, - -text => '<-', - -command=>sub{ - #-------------------------------- - # Negative rotation - #-------------------------------- - my @centre=$zinc->coords("$wp2"); #the center of the rotation is $wp2 - $zinc->rotate("$wp_group",-$PI/6,$centre[0],$centre[1]); - })->pack(-side => 'left'); - -my $right=$rc->Button(-width => 2, - -height => 2, - -text => '->', - -command=>sub{ - #-------------------------------- - # Positive rotation - #-------------------------------- - my @centre=$zinc->coords("$wp2");#the center of the rotation is $wp2 - $zinc->rotate("$wp_group",+$PI/6,$centre[0],$centre[1]); - })->pack(-side=>'right'); - - - - -MainLoop; diff --git a/Perl/demos/Tk/demos/zinc_lib/simple_interaction_track.pl b/Perl/demos/Tk/demos/zinc_lib/simple_interaction_track.pl deleted file mode 100644 index 2ceb925..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/simple_interaction_track.pl +++ /dev/null @@ -1,269 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# This simple demo has been developped by C. Schlienger - -package simple_interaction_track; # for avoiding symbol collision between different demos - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - - -use Tk; -use Tk::Zinc; -use strict; - -my $mw = MainWindow->new(); - - - -########################################### -# Zinc -########################################### -my $zinc_width=600; -my $zinc_height=500; -my $zinc = $mw->Zinc(-width => $zinc_width, -height => $zinc_height, - -font => "10x20", - -borderwidth => 3, -relief => 'sunken', - )->pack; - -# The explanation displayed when running this demo -$zinc->add('text', 1, - -position=> [10,10], - -text => 'This toy-appli shows some interactions on different parts -of a flight track item. The following operations are possible: - - Drag Button 1 on the track to move it. - Please Note the position history (past positions) - - Enter/Leave flight label fields - - Enter/Leave the speedvector, symbol (i.e. current position), - label, or leader', - -font => "9x15", - ); - -########################################### -# Track -########################################### - -#the label format (6 formats for 6 fields)# -my $labelformat = "x80x60+0+0 x60a0^0^0 x30a0^0>1 a0a0>2>1 x30a0>3>1 a0a0^0>2"; - -#the track# -my $x=250; -my $y=200; -my $track=$zinc->add('track', 1, 6, # 6 is the number of field in the flightlabel - -labelformat => $labelformat, - -position => [$x, $y],#position of the marker - -speedvector => [30, -15],#ccords of the speed vector - -markersize => 10, - ); -# moving the track, to display past positions -foreach my $i (0..5) { $zinc->coords($track,[$x+$i*10,$y-$i*5]); } - -#fields of the label# -$zinc->itemconfigure($track, 0,#configuration of field 0 of the label - -filled => 0, - -bordercolor => 'DarkGreen', - -border => "contour", - ); -$zinc->itemconfigure($track, 1, - -filled => 1, - -backcolor => 'gray60', - -text => "AFR6128"); -$zinc->itemconfigure($track, 2, - -filled => 0, - -backcolor => 'gray65', - -text => "390"); -$zinc->itemconfigure($track, 3, - -filled => 0, - -backcolor => 'gray65', - -text => "/"); -$zinc->itemconfigure($track, 4, - -filled => 0, - -backcolor => 'gray65', - -text => "350"); -$zinc->itemconfigure($track, 5, - -filled => 0, - -backcolor => 'gray65', - -text => "TUR"); - - - -########################################### -# Events on the track -########################################### -#--------------------------------------------- -# Enter/Leave a field of the label of the track -#--------------------------------------------- - -foreach my $field (0..5) { - #Entering the field $field higlights it# - $zinc->bind("$track:$field", - '', - sub { - if ($field==0){ - higlight_label_on(); -# print "CP=", $zinc->currentpart, "\n"; - } - else{ - highlight_fields_on($field); -# print "CP=", $zinc->currentpart, "\n"; - } - - }); - #Leaving the field cancels the highlight of $field# - $zinc->bind("$track:$field", - '', - sub { - if($field==0){ - higlight_label_off(); - } - else{ - if ($field==1){ - highlight_field1_off(); - } - else{ - highlight_other_fields_off($field); - } - } - }); -} - -#fonction# -sub higlight_label_on{ - $zinc->itemconfigure('current', 0, - -filled => 0, - -bordercolor => 'red', - -border => "contour", - ); - -} -sub higlight_label_off{ - $zinc->itemconfigure('current', 0, - -filled => 0, - -bordercolor => 'DarkGreen', - -border => "contour", - ); - - -} - -sub highlight_fields_on{ - my $field=$_[0]; - $zinc->itemconfigure('current', $field, - -border => 'contour', - -filled => 1, - -color => 'white' - ); - -} -sub highlight_field1_off{ - $zinc->itemconfigure('current', 1, - -border => '', - -filled => 1, - -color => 'black', - -backcolor => 'gray60' - ); - -} - -sub highlight_other_fields_off{ - my $field=$_[0]; - $zinc->itemconfigure('current', $field, - -border => '', - -filled => 0, - -color => 'black', - -backcolor => 'gray65' - ); -} -#--------------------------------------------- -# Enter/Leave other parts of the track -#--------------------------------------------- -$zinc->bind("$track:position", - '', - sub { $zinc->itemconfigure($track, - -symbolcolor=>"red", - ); -# print "CP=", $zinc->currentpart, "\n"; - }); -$zinc->bind("$track:position", - '', - sub { $zinc->itemconfigure($track, - -symbolcolor=>"black", - ); - }); - -$zinc->bind("$track:speedvector", - '', - sub { $zinc->itemconfigure($track, - -speedvectorcolor=>"red", - ); - }); -$zinc->bind("$track:speedvector", '', - sub { $zinc->itemconfigure($track, - -speedvectorcolor=>"black", - ); - }); - -$zinc->bind("$track:leader", '', - sub { $zinc->itemconfigure($track, - -leadercolor=>"red", - ); - }); - -$zinc->bind("$track:leader", '', - sub { $zinc->itemconfigure($track, - -leadercolor=>"black", - ); - }); - -#--------------------------------------------- -# Drag and drop the track -#--------------------------------------------- -#Binding to ButtonPress event -> "move_on" state# -$zinc -> bind($track,''=>[ sub { &select_color_on(); #change the color - &move_on($_[1],$_[2]); #"move_on" state - }, Tk::Ev('x'),Tk::Ev('y') ]); - -#Binding to ButtonRelease event -> "move_off" state# -$zinc -> bind($track,''=>sub{&select_color_off(); #change the color - &move_off();}); #"move_off" state - -#"move_on" state# -sub move_on{ - my ($xi,$yi)=@_; - #Binding to Motion event -> move the track# - $zinc -> bind($track,''=> - [sub{move($xi,$yi,$_[1],$_[2]); #move the track - $xi=$_[1]; - $yi=$_[2]; - },Tk::Ev('x'),Tk::Ev('y')]); -} - -#"move_off" state# -sub move_off{ - #Motion event not allowed on track - $zinc -> bind($track,''=>""); -} - -#move the track# -sub move{ - my ($xi,$yi,$x,$y)=@_; - select_color_on(); - my @coords=$zinc->coords($track); - $zinc->coords($track,[$coords[0]+$x-$xi,$coords[1]+$y-$yi]); -} - - -sub select_color_on{ - $zinc->itemconfigure($track, - -speedvectorcolor=>"white", - -markercolor=>"white", - -leadercolor=>"white" ); -} - -sub select_color_off{ - $zinc->itemconfigure($track, - -speedvectorcolor=>"black", - -markercolor=>"black", - -leadercolor=>"black" ); -} - Tk::MainLoop; diff --git a/Perl/demos/Tk/demos/zinc_lib/simpleradar.pl b/Perl/demos/Tk/demos/zinc_lib/simpleradar.pl deleted file mode 100644 index 12c45a9..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/simpleradar.pl +++ /dev/null @@ -1,489 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# This simple radar has been initially developped by P. Lecoanet -# It has been adapted by C. Mertz for demo purpose. - -package simpleradar; # for avoiding symbol collision between different demos - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - - -use Tk; -use Tk::Zinc; - -use strict; - -# to find the SimpleRadarControls module -require Tk->findINC('demos/zinc_pm/SimpleRadarControls.pm'); - -my $mw = MainWindow->new(); - -my $text = $mw->Text(-relief => 'sunken', -borderwidth => 2, - -height => 11); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', - 'This a very simple radar display, where you can see flight tracks, - a so-called ministrip (green) and and extend flight label (tan background). - The following operations are possible: - Shift-Button 1 for using a squarre lasso (result in the terminal). - Click Button 2 for identifiying the closest item (result in the terminal). - Button 3 for dragging most items, but not the ministrip (not in the same group). - Shift-Button 3 for zooming independently on X and Y axis. - Ctrl-Button 3 for rotationg graphic objects. - Enter/Leave in flight label fields, speed vector, position and leader, - and in the ministrip fields. - Click Button 1 on flight track to display a route.'); - - - -################################################### -# creation zinc -################################################### -my $top = 1; -my $scale = 1.0; -my $center_x = 0.0; -my $center_y = 0.0; -my $zinc_width = 800; -my $zinc_height = 500; -my $delay = 2000; -my $rate = 0.3; -my %tracks = (); - -my $pause = 0; # if true the flight are no more moving -my $zinc = $mw->Zinc(-backcolor => 'gray65', - -relief => 'sunken', - -font => "10x20"); -$zinc->pack(-expand => 1, -fill => 'both'); -$zinc->configure(-width => $zinc_width, -height => $zinc_height); -#$radar = $top; -my $radar = $zinc->add('group', $top, -tags => ['controls', 'radar']); -$zinc->configure(-overlapmanager => $radar); - - -################################################### -# creation panneau controle -################################################### -my $rc = $mw->Frame()->pack(); -$rc->Button(-text => 'Up', - -command => sub { $center_y -= 30.0; - update_transform($zinc); })->grid(-row => 0, - -column => 2, - -sticky, 'ew'); -$rc->Button(-text => 'Down', - -command => sub { $center_y += 30.0; - update_transform($zinc); })->grid(-row => 2, - -column => 2, - -sticky, 'ew'); -$rc->Button(-text => 'Left', - -command => sub { $center_x += 30.0; - update_transform($zinc); })->grid(-row => 1, - -column => 1); -$rc->Button(-text => 'Right', - -command => sub { $center_x -= 30.0; - update_transform($zinc); })->grid(-row => 1, - -column => 3); -$rc->Button(-text => 'Expand', - -command => sub { $scale *= 1.1; - update_transform($zinc); })->grid(-row => 1, - -column => 4); -$rc->Button(-text => 'Shrink', - -command => sub { $scale *= 0.9; - update_transform($zinc); })->grid(-row => 1, - -column => 0); -$rc->Button(-text => 'Reset', - -command => sub { $scale = 1.0; - $center_x = $center_y = 0.0; - update_transform($zinc); })->grid(-row => 1, - -column => 2, - -sticky, 'ew'); - -$rc->Button(-text => 'Pause', - -command => sub { $pause = ! $pause; - })->grid(-row => 0, - -column => 6); - -################################################### -# Code de reconfiguration lors d'un -# redimensionnement. -################################################### -$zinc->Tk::bind('', [\&resize]); - -sub resize { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - my $width = $ev->w; - my $height = $ev->h; - my $bw = $zinc->cget(-borderwidth); - $zinc_width = $width - 2*$bw; - $zinc_height = $height - 2*$bw; - update_transform($zinc); -} - -sub update_transform { - my ($zinc) = @_; - $zinc->treset($top); - $zinc->translate($top, -$center_x, -$center_y); - $zinc->scale($top, $scale, $scale); - $zinc->scale($top, 1, -1); - $zinc->translate($top, $zinc_width/2, $zinc_height/2); -} - - -################################################### -# Creation de pistes. -################################################### -my $one_of_track_item; -sub create_tracks { - my $i = 20; - my $j; - my $track; - my $x; - my $y; - my $w = $zinc_width / $scale; - my $h = $zinc_height / $scale; - my $d; - my $item; - - for ( ; $i > 0; $i--) { - $track = {}; - $track->{'item'} = $item = $zinc->add('track', $radar, 6); - $one_of_track_item = $item; - $tracks{$item} = $track; - $track->{'x'} = rand($w) - $w/2 + $center_x; - $track->{'y'} = rand($h) - $h/2 + $center_y; - $d = (rand() > 0.5) ? 1 : -1; - $track->{'vx'} = (8.0 + rand(10.0)) * $d; - $d = (rand() > 0.5) ? 1 : -1; - $track->{'vy'} = (8.0 + rand(10.0)) * $d; - $zinc->itemconfigure($item, - -position => [$track->{'x'}, $track->{'y'}], - -speedvector => [$track->{'vx'}, $track->{'vy'}], - -speedvectorsensitive => 1, - -labeldistance => 30, - -markersize => 20, - -historycolor => 'gray30', - -filledhistory => 0, - -circlehistory => 1, - -labelformat => "x80x60+0+0 x63a0^0^0 x33a0^0>1 a0a0>2>1 x33a0>3>1 a0a0^0>2"); - $zinc->itemconfigure($item, 0, - -filled => 0, - -backcolor => 'gray60', -# -border => "contour", - -sensitive => 1 - ); - $zinc->itemconfigure($item, 1, - -filled => 1, - -backcolor => 'gray55', - -text => sprintf ("AFR%03i",$i)); - $zinc->itemconfigure($item, 2, - -filled => 0, - -backcolor => 'gray65', - -text => "360"); - $zinc->itemconfigure($item, 3, - -filled => 0, - -backcolor => 'gray65', - -text => "/"); - $zinc->itemconfigure($item, 4, - -filled => 0, - -backcolor => 'gray65', - -text => "410"); - $zinc->itemconfigure($item, 5, - -filled => 0, - -backcolor => 'gray65', - -text => "Balise"); - my $b_on = sub { $zinc->itemconfigure('current', $zinc->currentpart(), - -border => 'contour')}; - my $b_off = sub { $zinc->itemconfigure('current', $zinc->currentpart(), - -border => 'noborder')}; - my $tog_b = sub { my $current = $zinc->find('withtag', 'current'); - my $curpart = $zinc->currentpart(); - if ($curpart =~ '[0-9]+') { - my $on_off = $zinc->itemcget($current, $curpart, -sensitive); - $zinc->itemconfigure($current, $curpart, - -sensitive => !$on_off); - } - }; - for ($j = 0; $j < 6; $j++) { - $zinc->bind($item.":$j", '', $b_on); - $zinc->bind($item.":$j", '', $b_off); - $zinc->bind($item, '<1>', $tog_b); - $zinc->bind($item, '', sub {}); - } - $zinc->bind($item, '', - sub {$zinc->itemconfigure('current', - -historycolor => 'red3', - -symbolcolor => 'red3', - -markercolor => 'red3', - -leaderwidth => 2, - -leadercolor => 'red3', - -speedvectorwidth => 2, - -speedvectorcolor => 'red3')}); - $zinc->bind($item, '', - sub {$zinc->itemconfigure('current', - -historycolor => 'black', - -symbolcolor => 'black', - -markercolor => 'black', - -leaderwidth => 1, - -leadercolor => 'black', - -speedvectorwidth => 1, - -speedvectorcolor => 'black')}); - $zinc->bind($item.':position', '<1>', [\&create_route]); - $zinc->bind($item.':position', '', sub { }); - $track->{'route'} = 0; - } -} - -create_tracks(); - -################################################### -# creation way point -################################################### -sub create_route { - my ($zinc) = @_; - my $wp; - my $connected; - my $x; - my $y; - my $i = 4; - my $track = $tracks{$zinc->find('withtag', 'current')}; - - if ($track->{'route'} == 0) { - $x = $track->{'x'} + 8.0 * $track->{'vx'}; - $y = $track->{'y'} + 8.0 * $track->{'vy'}; - $connected = $track->{'item'}; - for ( ; $i > 0; $i--) { - $wp = $zinc->add('waypoint', 'radar', 2, - -position => [$x, $y], - -connecteditem => $connected, - -connectioncolor => 'green', - -symbolcolor => 'green', - -labelformat => 'x20x18+0+0'); - $zinc->lower($wp, $connected); - $zinc->bind($wp.':0', '', - sub {$zinc->itemconfigure('current', 0, -border => 'contour')}); - $zinc->bind($wp.':position', '', - sub {$zinc->itemconfigure('current', -symbolcolor => 'red')}); - $zinc->bind($wp.':leader', '', - sub {$zinc->itemconfigure('current', -leadercolor => 'red')}); - $zinc->bind($wp.':connection', '', - sub {$zinc->itemconfigure('current', -connectioncolor => 'red')}); - $zinc->bind($wp.':0', '', - sub {$zinc->itemconfigure('current', 0, -border => '')}); - $zinc->bind($wp.':position', '', - sub {$zinc->itemconfigure('current', -symbolcolor => 'green')}); - $zinc->bind($wp.':leader', '', - sub {$zinc->itemconfigure('current', -leadercolor => 'black')}); - $zinc->bind($wp.':connection', '', - sub {$zinc->itemconfigure('current', -connectioncolor => 'green')}); - $zinc->itemconfigure($wp, 0, - -text => "$i", - -filled => 1, - -backcolor => 'gray55'); - $zinc->bind($wp.':position', '<1>', [\&del_way_point]); - $x += (2.0 + rand(8.0)) * $track->{'vx'}; - $y += (2.0 + rand(8.0)) * $track->{'vy'}; - $connected = $wp; - } - $track->{'route'} = $wp; - } - else { - $wp = $track->{'route'}; - while ($wp != $track->{'item'}) { - $track->{'route'} = $zinc->itemcget($wp, -connecteditem); - $zinc->bind($wp.':position', '<1>', ''); - $zinc->bind($wp.':position', '', ''); - $zinc->bind($wp.':position', '', ''); - $zinc->bind($wp.':leader', '', ''); - $zinc->bind($wp.':leader', '', ''); - $zinc->bind($wp.':connection', '', ''); - $zinc->bind($wp.':connection', '', ''); - $zinc->bind($wp.':0', '', ''); - $zinc->bind($wp.':0', '', ''); - $zinc->remove($wp); - $wp = $track->{'route'}; - } - $track->{'route'} = 0; - } -} - -################################################### -# suppression waypoint intermediaire -################################################### -sub find_track { - my ($zinc, $wp) = @_; - my $connected = $wp; - - while ($zinc->type($connected) ne 'track') { - $connected = $zinc->itemcget($connected, -connecteditem); - } - return $connected; -} - -sub del_way_point { - my ($zinc) = @_; - my $wp = $zinc->find('withtag', 'current'); - my $track = $tracks{find_track($zinc, $wp)}; - my $next = $zinc->itemcget($wp, -connecteditem); - my $prev; - my $prevnext; - - $prev = $track->{'route'}; - if ($prev != $wp) { - $prevnext = $zinc->itemcget($prev, -connecteditem); - while ($prevnext != $wp) { - $prev = $prevnext; - $prevnext = $zinc->itemcget($prev, -connecteditem); - } - } - $zinc->itemconfigure($prev, -connecteditem => $next); - $zinc->bind($wp.':position', '<1>', ''); - $zinc->remove($wp); - if ($wp == $track->{'route'}) { - if ($next == $track->{'item'}) { - $track->{'route'} = 0; - } - else { - $track->{'route'} = $next; - } - } -} - - -################################################### -# creation macro -################################################### -my $macro = $zinc->add("tabular", $radar, 10, - -labelformat => "x73x20+0+0 x20x20+0+0 x53x20+20+0" - ); -$zinc->itemconfigure($macro, 0, -backcolor => "tan1", -filled => 1, - -fillpattern => "AlphaStipple7", - -bordercolor => "red3"); -$zinc->itemconfigure($macro, 1 , -text => "a"); -$zinc->itemconfigure($macro, 2, -text => "macro"); - -$zinc->itemconfigure($macro, -connecteditem => $one_of_track_item); -foreach my $part (0..2) { - $zinc->bind("$macro:$part", "", [ \&borders, "on"]); - $zinc->bind("$macro:$part", "", [ \&borders, "off"]); -} -################################################### -# creation ministrip -################################################### -my $ministrip = $zinc->add("tabular", 1, 10, - -labelformat => "x153x80^0^0 x93x20^0^0 x63a0^0>1 a0a0>2>1 x33a0>3>1 a0a0^0>2", - -position => [100, 10]); -$zinc->itemconfigure($ministrip, 0 , - -filled => 1, - -backcolor => "grey70", - -border => "contour", - -bordercolor => "green", - ); -$zinc->itemconfigure($ministrip, 1 , - -text => 'ministrip', -color => "darkgreen", - -backcolor => "grey40", - ); -$zinc->itemconfigure($ministrip, 2 , - -text => 'field1', -color => "darkgreen", - -backcolor => "grey40", - ); -$zinc->itemconfigure($ministrip, 3 , - -text => 'field2', -color => "darkgreen", - -backcolor => "grey40", - ); -$zinc->itemconfigure($ministrip, 4 , - -text => 'f3', -color => "darkgreen", - -backcolor => "grey40", - ); -$zinc->itemconfigure($ministrip, 5 , - -text => 'field4', -color => "darkgreen", - -backcolor => "grey40", - ); - -foreach my $field (1..5) { - $zinc->bind("$ministrip:$field", '', - sub { - $zinc->itemconfigure('current', $field, - -border => 'contour', - -filled => 1, - -color => 'white' - ) - }); -$zinc->bind("$ministrip:$field", '', - sub {$zinc->itemconfigure('current', $field, - -border => '', - -filled => 0, - -color => 'darkgreen' - )}); -} - -################################################### -# creation map -################################################### -$mw->videomap("load", Tk->findINC("demos/zinc_data/videomap_paris-w_90_2"), 0, "paris-w"); -$mw->videomap("load", Tk->findINC("demos/zinc_data/videomap_orly"), 17, "orly"); -$mw->videomap("load", Tk->findINC("demos/zinc_data/hegias_parouest_TE.vid"), 0, "paris-ouest"); - -my $map = $zinc->add("map", $radar, - -color => 'gray80'); -$zinc->itemconfigure($map, - -mapinfo => 'orly'); - -my $map2 = $zinc->add("map", $radar, - -color => 'gray60', - -filled => 1, - -priority => 0, - -fillpattern => "AlphaStipple6"); -$zinc->itemconfigure($map2, - -mapinfo => 'paris-ouest'); - -my $map3 = $zinc->add("map", $radar, - -color => 'gray50'); -$zinc->itemconfigure($map3, - -mapinfo => "paris-w"); - - -################################################### -# Création fonctions de contrôle à la souris -################################################### -new SimpleRadarControls($zinc); - -################################################### -# Rafraichissement des pistes -################################################### -my $timer = $zinc->repeat($delay, [\&refresh, $zinc]); -$mw->OnDestroy(\&destroyTimersub ); # this is - -my $timerIsDead = 0; -sub destroyTimersub { - $timerIsDead = 1; - $mw->afterCancel($timer); - # the timer is not really cancelled when using zinc-demos! -} - -sub refresh { - my ($zinc) = @_; - - return if $pause; - return if $timerIsDead; - foreach my $t (values(%tracks)) { - $t->{'x'} += $t->{'vx'} * $rate; - $t->{'y'} += $t->{'vy'} * $rate; - $zinc->itemconfigure($t->{'item'}, - -position => [$t->{'x'}, $t->{'y'}]); - } -} - -sub borders { - my($widget, $onoff) = @_; - $onoff = "on" unless $onoff; - my $contour = "noborder"; - $contour = "contour" if ($onoff eq 'on'); - $zinc->itemconfigure('current', 0, -border => $contour); -} - - -Tk::MainLoop(); - - diff --git a/Perl/demos/Tk/demos/zinc_lib/testGraphics.pl b/Perl/demos/Tk/demos/zinc_lib/testGraphics.pl deleted file mode 100644 index 5da149b..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/testGraphics.pl +++ /dev/null @@ -1,1845 +0,0 @@ -#!/usr/bin/perl -#----------------------------------------------------------------------------------- -# -# testGraphics.pl -# Fichier test du module Graphics -# -# Authors: Jean-Luc Vinot -# -# $Id$ -#----------------------------------------------------------------------------------- - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use Tk::Zinc::Graphics; -use Math::Trig; -use Getopt::Long; -use strict 'vars'; - - -my $currenttransfo; -my $previousangle = 0; -my $rotate_angle = .1; -my $zoomfactor = .1; -my $curview; -my ($dx, $dy); - -my $tabanchor = 'n'; -my $tabalign = 'left'; - -my $font_9b = '7x13bold'; -# the original font is not standard, even if it is fully free: -# my $font_9b = '-cenapii-bleriot mini-bold-r-normal--9-90-75-75-p-75-iso8859-15'; - -my %gradset = (# gradients zinc - 'boitonglet' => '=axial 0|#ff7777|#ffff99', - 'roundrect1' => '=axial 270|#a7ffa7;70 0|#ffffff;90 5|#00bd00;80 8|#b7ffb7;50 80|#ffffff;70 91|#00ac00;70 95|#006700;60 100', - 'roundrect2' => '=axial 270|#00bd00;80 |#d7ffd7;60', - 'roundrect3' => '=axial 270|#00bd00;100 0|#ffffff;100 14|#ffffff;100 16|#00bd00;90 25|#b7ffb7;60 100', - 'roundrect4' => '=axial 0|#00bd00;100 0|#ffffff;100 20|#00bd00;50 30|#00bd00;90 80|#b7ffb7;60 100', - 'roundrect4ed' => '=path 48 48|#e7ffe7;20 0 70|#007900;20', - 'roundcurve2' => '=axial 270|#d7ffd7;60|#7777ff;80', - 'roundcurve1' => '=axial 270|#2222ff;80 |#d7ffd7;60', - 'roundcurve' => '=axial 270|#7777ff;80 |#d7ffd7;60', - 'roundpolyg' => '=radial -15 -20|#ffb7b7;50|#bd6622;90', - 'rpolyline' => '=axial 90|#ffff77;80 |#ff7700;60', - 'pushbtn1' => '=axial 0|#cccccc;100 0|#ffffff;100 10|#5a5a6a;100 80|#aaaadd;100 100', - 'pushbtn2' => '=axial 270|#ccccff;100 0|#ffffff;100 10|#5a5a7a;100 80|#bbbbee;100 100', - 'pushbtn3' => '=radial -15 -15|#ffffff;100 0|#333344;100 100', - 'pushbtn4' => '=axial 270|#ccccff;100 0|#ffffff;100 10|#7a7a9a;100 80|#bbbbee;100 100', - 'conical_edge' => '=conical 0 0 -45|#ffffff;100 0|#888899;100 30|#555566;100 50|#888899;100 70|#ffffff;100 100', - 'conical_ext' => '=conical 0 0 135|#ffffff;100 0|#777788;100 30|#444455;100 50|#777788;100 70|#ffffff;100 100', - 'pushbtn_edge' => '=axial 140|#ffffff;100 0|#555566;100 100', - 'pushbtn_edge2' => '=axial 92|#ffffff;100 0|#555566;100 100', - 'logoshape2' => '=axial 270|#ffffff|#7192aa', - 'logopoint2' => '=radial -20 -20|#ffffff 0|#f70000 48|#900000 80|#ab0000 100', - 'logoptshad2' => '=path 0 0|#770000;64 0|#770000;70 78|#770000;0 100', - ); - - -# contenu des pages exemples -my %pagesconf = ('Rectangle' => {'consigne' => {-itemtype => 'text', - -coords => [-285, 155], - -params => {-font => $font_9b, - -text => "Mouse button 1 drag objects,\nEscape key reset transfos.", - -color => '#2222cc', - }, - }, - # roudedrectangle simple + radius 20 - 'rr1' => {-itemtype => 'roundedrectangle', - -coords => [[-200, 30], [50, 130]], - -radius => 20, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundrect2', - -linewidth => 2, - -linecolor => '#000000', - -priority => 20, - -tags => ['move'], - }, - }, - - # roudedrectangle 'carré' (radius automatique) - 'rr2' => {-itemtype => 'roundedrectangle', - -coords => [[-250, -100], [-90, 60]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundrect1', - -linewidth => 3, - -linecolor => '#000000', - -priority => 30, - -tags => ['move'], - }, - }, - # cas particulier -> hippodrome (radius = h/2) - 'rr3' => {-itemtype => 'roundedrectangle', - -coords => [[-30, 80], [130, 160]], - -radius => 40, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundrect3', - -linewidth => 4, - -linecolor => '#000000', - -priority => 30, - -tags => ['move'], - }, - }, - - # utilisation de l'option -corners (pétales de fleur) - 'rr4a' => {-itemtype => 'roundedrectangle', - -coords => [[-30, -60], [110, 10]], - -radius => 40, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundrect3', - -linewidth => 3, - -linecolor => '#000000', - -priority => 30, - -tags => ['move'], - }, - -corners => [1, 0, 1, 0], - }, - 'rr4b' => {-itemtype => 'roundedrectangle', - -coords => [[118, -68], [220, -132]], - -radius => 40, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundrect3', - -linewidth => 3, - -linecolor => '#000000', - -priority => 30, - -tags => ['move'], - }, - -corners => [1, 0, 1, 0], - }, - 'rr4c' => {-itemtype => 'roundedrectangle', - -coords => [[118, -60], [190, 30]], - -radius => 40, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundrect3', - -linewidth => 3, - -linecolor => '#000000', - -priority => 30, - -tags => ['move'], - }, - -corners => [0, 1, 0, 1], - }, - 'rr4d' => {-itemtype => 'roundedrectangle', - -coords => [[40, -152], [110, -68]], - -radius => 40, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundrect3', - -linewidth => 3, - -linecolor => '#000000', - -priority => 30, - -tags => ['move'], - }, - -corners => [0, 1, 0, 1], - }, - - # groupe de 2 boutons avec bordure externe - 'gr8' => {-itemtype => 'group', - -coords => [0, 0], - -params => {-priority => 10, - -tags => ['move'], - -atomic => 1, - }, - -items => {'edge' => {-itemtype => 'roundedrectangle', - -coords => [[174, -36],[266, 146]], - -radius => 26, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundrect4ed', - -linewidth => 1, - -linecolor => '#ffffff', - -priority => 20, - }, - }, - 'top' => {-itemtype => 'roundedrectangle', - -coords => [[180, -30], [260, 53]], - -parentgroup => 'gr8', - -radius => 20, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundrect4', - -linewidth => 2.5, - -linecolor => '#000000', - -priority => 30, - }, - -corners => [1, 0, 0, 1], - }, - 'topico' => {-itemtype => 'curve', - -parentgroup => 'gr8', - -coords => [[220, -10],[200, 30],[240, 30]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => '#ffff00;80', - -linewidth => 1, - -linecolor => '#007900;80', - -priority => 50, - }, - }, - 'bottom' => {-itemtype => 'roundedrectangle', - -parentgroup => 'gr8', - -coords => [[180, 57], [260, 140]], - -radius => 20, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundrect4', - -linewidth => 2.5, - -linecolor => '#000000', - -priority => 30, - }, - -corners => [0, 1, 1, 0], - }, - 'bottomico' => {-itemtype => 'curve', - -parentgroup => 'gr8', - -coords => [[220, 120],[240, 80],[200, 80]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => '#ffff00;80', - -linewidth => 1, - -linecolor => '#007900;80', - -priority => 50, - }, - }, - }, - }, - }, - 'Hippodrome' => {'consigne' => {-itemtype => 'text', - -coords => [-285, 165], - -params => {-font => $font_9b, - -text => "Click hippo Buttons with mouse button 1.\n", - -color => '#2222cc', - }, - }, - 'hp1' => {-itemtype => 'group', - -coords => [-163, -40], - -params => {-priority => 40, - }, - -items => {'edge' => {-itemtype => 'hippodrome', - -coords => [[-46, -86], [46, 86]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn_edge', - -linewidth => 1, - -linecolor => '#ffffff', - -priority => 10, - }, - }, - 'form' => {-itemtype => 'hippodrome', - -coords => [[-40, -80], [40, 80]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn1', - -linewidth => 3, - -linecolor => '#000000', - -priority => 20, - -tags => ['b1','pushbtn'], - }, - }, - }, - }, - - 'hp2' => {-itemtype => 'group', - -coords => [-40, -40], - -params => {-priority => 40, - }, - -items => {'edge' => {-itemtype => 'hippodrome', - -coords => [[-46, -86], [46, 86]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn_edge', - -linewidth => 1, - -linecolor => '#ffffff', - -priority => 10, - }, - }, - 'formT' => {-itemtype => 'hippodrome', - -coords => [[-40, -80], [40, -28]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn1', - -linewidth => 3, - -linecolor => '#000000', - -priority => 20, - -tags => ['b2t','pushbtn'], - }, - -orientation => 'vertical', - -trunc => 'bottom', - }, - 'formC' => {-itemtype => 'hippodrome', - -coords => [[-40, -26.5], [40, 26.5]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn1', - -linewidth => 3, - -linecolor => '#000000', - -priority => 20, - -tags => ['b2c','pushbtn'], - }, - -trunc => 'both', - }, - 'formB' => {-itemtype => 'hippodrome', - -coords => [[-40, 28], [40, 80]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn1', - -linewidth => 3, - -linecolor => '#000000', - -priority => 20, - -tags => ['b2b','pushbtn'], - }, - -orientation => 'vertical', - -trunc => 'top', - }, - }, - }, - 'hp3edge' => {-itemtype => 'hippodrome', - -coords => [[-204, 96], [204, 144]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn_edge2', - -linewidth => 1, - -linecolor => '#ffffff', - -priority => 10, - }, - }, - 'hp3g' => {-itemtype => 'group', - -coords => [-160, 120], - -params => {-priority => 40, - }, - -items => {'form' => {-itemtype => 'hippodrome', - -coords => [[-40, -20], [40, 20]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn2', - -linewidth => 2, - -linecolor => '#000000', - -priority => 20, - -tags => ['b3g','pushbtn'], - }, - -trunc => 'right', - }, - 'ico' => {-itemtype => 'curve', - -coords => [[-20, 0],[-4, 8],[-4, -8]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => '#000000', - -linewidth => 1, - -linecolor => '#aaaaaa', - -relief => 'raised', - -priority => 30, - -tags => ['b3g','pushbtn','ico'], - }, - -contours => [['add',-1,[[0, 0],[16, 8],[16, -8]]]], - }, - }, - }, - 'hp3c1' => {-itemtype => 'group', - -coords => [-80, 120], - -params => {-priority => 40, - }, - -items => {'form' => {-itemtype => 'hippodrome', - -coords => [[-38, -20], [39, 20]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn2', - -linewidth => 2, - -linecolor => '#000000', - -priority => 20, - -tags => ['b3c1','pushbtn'], - }, - -trunc => 'both', - }, - 'ico' => {-itemtype => 'curve', - -coords => [[-8, 0],[8, 8],[8, -8]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => '#000000', - -linewidth => 1, - -linecolor => '#aaaaaa', - -priority => 30, - -relief => 'raised', - -tags => ['b3c1','pushbtn','ico'], - }, - }, - }, - }, - 'hp3c2' => {-itemtype => 'group', - -coords => [0, 120], - -params => {-priority => 40, - }, - -items => {'form' => {-itemtype => 'hippodrome', - -coords => [[-39, -20], [39, 20]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn2', - -linewidth => 2, - -linecolor => '#000000', - -priority => 20, - -tags => ['b3c2','pushbtn'], - }, - -trunc => 'both', - }, - 'ico' => {-itemtype => 'rectangle', - -coords => [[-6, -6],[6, 6]], - -params => {-filled => 1, - -fillcolor => '#000000', - -linewidth => 1, - -linecolor => '#aaaaaa', - -priority => 30, - -tags => ['b3c2','pushbtn','ico'], - }, - }, - }, - }, - 'hp3C3' => {-itemtype => 'group', - -coords => [80, 120], - -params => {-priority => 40, - }, - -items => {'form' => {-itemtype => 'hippodrome', - -coords => [[-39, -20], [39, 20]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn2', - -linewidth => 2, - -linecolor => '#000000', - -priority => 20, - -tags => ['b3c3','pushbtn'], - }, - -trunc => 'both', - }, - 'ico' => {-itemtype => 'curve', - -coords => [[8, 0],[-8, -8],[-8, 8]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => '#000000', - -linewidth => 1, - -linecolor => '#aaaaaa', - -priority => 30, - -relief => 'raised', - -tags => ['b3c3','pushbtn','ico'], - }, - }, - }, - }, - - 'hp3D' => {-itemtype => 'group', - -coords => [160, 120], - -params => {-priority => 40, - }, - -items => {'form' => {-itemtype => 'hippodrome', - -coords => [[-40, -20], [40, 20]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn2', - -linewidth => 2, - -linecolor => '#000000', - -priority => 20, - -tags => ['b3d','pushbtn'], - }, - -trunc => 'left', - }, - 'ico' => {-itemtype => 'curve', - -coords => [[20, 0],[4, -8],[4, 8]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => '#000000', - -linewidth => 1, - -linecolor => '#aaaaaa', - -priority => 30, - -relief => 'raised', - -tags => ['b3d','pushbtn','ico'], - }, - -contours => [['add',-1,[[0,0],[-16, -8],[-16, 8]]]], - }, - }, - }, - - 'hp4a' => {-itemtype => 'group', - -coords => [48, -97], - -params => {-priority => 40, - }, - -repeat => {-num => 2, - -dxy => [0, 64], - }, - -items => {'edge' => {-itemtype => 'hippodrome', - -coords => [[-29, -29], [29, 29]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn_edge', - -linewidth => 1, - -linecolor => '#ffffff', - -priority => 0, - }, - }, - 'form' => {-itemtype => 'hippodrome', - -coords => [[-24, -24], [24, 24]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn3', - -linewidth => 3, - -linecolor => '#000000', - -priority => 30, - -tags => ['b4a','pushbtn'], - }, - }, - }, - }, - - 'hp4b' => {-itemtype => 'group', - -coords => [145, -65], - -params => {-priority => 40, - }, - -items => {'edge' => {-itemtype => 'hippodrome', - -coords => [[-60, -60], [60, 60]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'conical_edge', - -linewidth => 1, - -linecolor => '#ffffff', - -priority => 0, - }, - }, - 'ext' => {-itemtype => 'hippodrome', - -coords => [[-53, -53], [53, 53]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'conical_ext', - -linewidth => 3, - -linecolor => '#000000', - -priority => 10, - -tags => ['b4b','pushbtn'], - }, - }, - 'int' => {-itemtype => 'hippodrome', - -coords => [[-41, -41], [40, 40]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => '=path 10 10|#ffffff 0|#ccccd0 50|#99999f 80|#99999f;0 100', - -linewidth => 0, - -linecolor => '#cccccc;80', - -priority => 30, - -tags => ['b4b','pushbtn'], - }, - }, - }, - }, - - 'hp5' => {-itemtype => 'group', - -coords => [60, 25], - -params => {-priority => 40, - }, - -rotate => 30, - -repeat => {-num => 4, - -dxy => [45, 0], - }, - -items => {'edge' => {-itemtype => 'hippodrome', - -coords => [[-19, -34], [19, 34]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn_edge', - -linewidth => 1, - -linecolor => '#ffffff', - -priority => 10, - }, - }, - 'form' => {-itemtype => 'hippodrome', - -coords => [[-15, -30], [15, 30]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn1', - -linewidth => 2, - -linecolor => '#000000', - -priority => 20, - -tags => ['b5','pushbtn'], - }, - }, - }, - }, - }, - - 'Polygone' => {'consigne' => {-itemtype => 'text', - -coords => [-285, 160], - -params => {-font => $font_9b, - -text => "Click and Drag inside Polygons for rotate them\nEscape key reset transfos.", - -color => '#2222cc', - }, - }, - 'triangle' => {-itemtype => 'group', - -coords => [-215, -95], - -items => {'form' => {-itemtype => 'polygone', - -coords => [0, 0], - -numsides => 3, - -radius => 78, - -corner_radius => 10, - -startangle => 90, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundpolyg', - -linewidth => 2, - -linecolor => '#330000', - -priority => 20, - -tags => ['p1', 'poly'], - }, - }, - 'text' => {-itemtype => 'text', - -coords => [0, -6], - -params => {-font => $font_9b, - -text => "Triangle", - -anchor => 'n', - -alignment => 'center', - -color => '#660000', - -priority => 50, - }, - }, - }, - }, - - 'carre' => {-itemtype => 'group', - -coords => [-80, -75], - -items => {'form' => {-itemtype => 'polygone', - -coords => [0, 0], - -numsides => 4, - -radius => 70, - -corner_radius => 10, - -startangle => 90, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundpolyg', - -linewidth => 2, - -linecolor => '#330000', - -priority => 20, - -tags => ['p2', 'poly'], - }, - }, - 'text' => {-itemtype => 'text', - -coords => [0, -6], - -params => {-font => $font_9b, - -text => "Carré", - -anchor => 'n', - -alignment => 'center', - -color => '#660000', - -priority => 50, - }, - }, - }, - }, - - 'pentagone' => {-itemtype => 'group', - -coords => [65, -75], - -items => {'form' => {-itemtype => 'polygone', - -coords => [0, 0], - -numsides => 5, - -radius => 70, - -corner_radius => 10, - -startangle => 270, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundpolyg', - -linewidth => 2, - -linecolor => '#330000', - -priority => 20, - -tags => ['p3', 'poly'], - }, - }, - 'text' => {-itemtype => 'text', - -coords => [0, -6], - -params => {-font => $font_9b, - -text => "Pentagone", - -anchor => 'n', - -alignment => 'center', - -color => '#660000', - -priority => 50, - }, - }, - }, - }, - - 'hexagone' => {-itemtype => 'group', - -coords => [210, -75], - -items => {'form' => {-itemtype => 'polygone', - -coords => [0, 0], - -numsides => 6, - -radius => 68, - -corner_radius => 10, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundpolyg', - -linewidth => 2, - -linecolor => '#330000', - -priority => 20, - -tags => ['p4', 'poly'], - }, - }, - 'text' => {-itemtype => 'text', - -coords => [0, -6], - -params => {-font => $font_9b, - -text => "Hexagone", - -anchor => 'n', - -alignment => 'center', - -color => '#660000', - -priority => 50, - }, - }, - }, - }, - - 'heptagone' => {-itemtype => 'group', - -coords => [-215, 85], - -items => {'form' => {-itemtype => 'polygone', - -coords => [0, 0], - -numsides => 7, - -radius => 64, - -corner_radius => 10, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundpolyg', - -linewidth => 2, - -linecolor => '#330000', - -priority => 20, - -tags => ['p5', 'poly'], - }, - }, - 'text' => {-itemtype => 'text', - -coords => [0, -6], - -params => {-font => $font_9b, - -text => "Heptagone", - -anchor => 'n', - -alignment => 'center', - -color => '#660000', - -priority => 50, - }, - }, - }, - }, - - - 'octogone' => {-itemtype => 'group', - -coords => [-76, 85], - -items => {'form' => {-itemtype => 'polygone', - -coords => [0, 0], - -numsides => 8, - -radius => 64, - -corner_radius => 10, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundpolyg', - -linewidth => 2, - -linecolor => '#330000', - -priority => 20, - -tags => ['p6', 'poly'], - }, - }, - 'text' => {-itemtype => 'text', - -coords => [0, -6], - -params => {-font => $font_9b, - -text => "Octogone", - -anchor => 'n', - -alignment => 'center', - -color => '#660000', - -priority => 50, - }, - }, - }, - }, - - 'petagone' => {-itemtype => 'group', - -coords => [66, 85], - -items => {'form' => {-itemtype => 'polygone', - -coords => [0, 0], - -numsides => 32, - -radius => 64, - -corner_radius => 10, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundpolyg', - -linewidth => 2, - -linecolor => '#330000', - -priority => 20, - -tags => ['p7', 'poly'], - }, - }, - 'text' => {-itemtype => 'text', - -coords => [0, -6], - -params => {-font => $font_9b, - -text => "32 cotés...", - -anchor => 'n', - -alignment => 'center', - -color => '#660000', - -priority => 50, - }, - }, - }, - }, - - 'etoile' => {-itemtype => 'group', - -coords => [210, 85], - -items => {'form' => {-itemtype => 'polygone', - -coords => [0, 0], - -numsides => 5, - -radius => 92, - -inner_radius => 36, - -corner_radius => 10, - -startangle => 270, - -corners => [0,1,0,1,0,1,0,1,0,1], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundpolyg', - -linewidth => 2, - -linecolor => '#330000', - -priority => 20, - -tags => ['p8', 'poly'], - }, - }, - 'text' => {-itemtype => 'text', - -coords => [0, -6], - -params => {-font => $font_9b, - -text => "Etoile", - -anchor => 'n', - -alignment => 'center', - -color => '#660000', - -priority => 50, - }, - }, - }, - }, - }, - - 'Polyline' => {'consigne' => {-itemtype => 'text', - -coords => [-285, 155], - -params => {-font => $font_9b, - -text => "Mouse button 1 drag objects,\nEscape key reset transfos.", - -color => '#2222cc', - }, - }, - 'a' => {-itemtype => 'polyline', - -coords => [[-200, -115],[-200, -100],[-218, -115],[-280, -115],[-280, -16], - [-218, -16],[-200, -31],[-200, -17.5],[-150, -17.5],[-150,-115]], - -corners_radius => [0, 0, 42, 47, 47, 42, 0, 0, 0, 0, 0, 0], - -params => {-closed => 1, - -filled => 1, - -visible => 1, - -fillcolor => 'rpolyline', - -linewidth => 2, - -linecolor => '#000000', - -priority => 50, - -tags => ['move'], - }, - -contours => [['add', -1, [[-230, -80],[-230, -50],[-200, -50],[-200, -80]],15]], - }, - 'b' => {-itemtype => 'polyline', - -coords => [[-138, -150],[-138, -17.5],[-88, -17.5],[-88, -31],[-70, -16], - [-8, -16],[-8, -115],[-70, -115],[-88, -100],[-88, -150]], - -corners_radius => [0, 0, 0, 0, 42, 47, 47, 42, 0, 0, 0, 0, 0, 0], - -params => {-closed => 1, - -filled => 1, - -visible => 1, - -fillcolor => 'rpolyline', - -linewidth => 2, - -linecolor => '#000000', - -priority => 50, - -tags => ['move'], - }, - -contours => [['add', -1, [[-88, -80],[-88, -50],[-58, -50],[-58, -80]],15]], - }, - 'c' => {-itemtype => 'polyline', - -coords => [[80, -76],[80, -110],[60, -115],[0, -115],[0, -16], - [60, -16],[80, -21],[80, -57],[50, -47],[50, -86]], - -corners_radius => [0, 0, 70, 47, 47, 70, 0, 0, 14, 14, 0, 0, 0,0 ], - -params => {-closed => 1, - -filled => 1, - -visible => 1, - -fillcolor => 'rpolyline', - -linewidth => 2, - -linecolor => '#000000', - -priority => 50, - -tags => ['move'], - }, - }, - 'spirale' => {-itemtype => 'polyline', - -coords => [[215, -144],[139, -144],[139, 0],[268, 0],[268, -116], - [162.5, -116],[162.5, -21],[248, -21],[248, -96],[183, -96], - [183, -40],[231,-40],[231, -80],[199, -80],[199, -55],[215, -55]], - -corners_radius => [0, 76, 68, 61, 55, 50, 45, 40, 35, 30, 26, 22, 18, 14, 11], - -params => {-closed => 1, - -filled => 1, - -visible => 1, - -fillcolor => 'rpolyline', - -linewidth => 2, - -linecolor => '#000000', - -priority => 50, - -tags => ['move'], - }, - }, - 'logo' => {-itemtype => 'group', - -coords => [0, 0], - -params => {-priority => 30, - -atomic => 1, - -tags => ['move'], - }, - -items => {'tkzinc' => {-itemtype => 'polyline', - -coords => [[-150,10],[-44,10],[-44,68],[-28,51],[6,51], - [-19,79],[3,109],[53,51],[5,51],[5,10],[140,10], - [52,115],[96,115],[96,47],[196,47],[196,158], - [155,158],[155,89],[139,89],[139,160],[101, 160], - [101,132],[85,132],[85,160],[-42,160],[-2,115], - [-30,115],[-46,91],[-46,115],[-76,115],[-76,51], - [-98,51],[-98,115],[-130,115],[-130,51],[-150, 51]], - -corners_radius => [0,0,0,0,0,0,0,0,0,0,30,0,0,50,50, - 0,0,8,8,0,0,8,8,0,27], - -params => {-closed => 1, - -filled => 1, - -visible => 1, - -fillcolor => 'logoshape2', - -linewidth => 2.5, - -linecolor => '#000000', - -priority => 10, - -fillrule => 'nonzero', - }, - - -contours => [['add', 1, [[245,88],[245,47],[190,47],[190,158], - [259,158],[259,117],[230,117],[230,88]], - 5, undef, [0,0,55,55,0,0,15,15]]], - }, - 'shad' => {-itemtype => 'arc', - -coords => [[75, 91],[115,131]], - -params => {-priority => 20, - -filled => 1, - -linewidth => 0, - -fillcolor => 'logoptshad2', - -closed => 1, - }, - }, - 'point' => {-itemtype => 'arc', - -coords => [[70, 86],[110,126]], - -params => {-priority => 50, - -filled => 1, - -linewidth => 1, - -linecolor => '#a10000', - -fillcolor => 'logopoint2', - -closed => 1, - }, - }, - }, - }, - }, - - 'MultiContours' => {'consigne' => {-itemtype => 'text', - -coords => [-285, 155], - -params => {-font => $font_9b, - -text => "Mouse button 1 drag objects,\nEscape key reset transfos.", - -color => '#2222cc', - }, - }, - 'mc1' => {-itemtype => 'roundedcurve', - -coords => [[-30, -170], [-130, 0],[70, 0]], - -radius => 14, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundcurve2', - -linewidth => 1, - -linecolor => '#000000', - -priority => 20, - -tags => ['move'], - -fillrule => 'odd', - }, - -contours => [['add',1,[[-30,-138],[-100,-18],[40,-18]],8], - ['add',1,[[-30,-130],[ -92,-22],[32,-22]],5], - ['add',1,[[-30,-100],[ -68,-36],[8,-36]],5], - ['add',1,[[-30, -92],[ -60,-40],[0,-40]],3],], - }, - 'mc2' => {-itemtype => 'polyline', - -coords => [[-250,-80], [-240,-10],[-285,-10],[-285,80], - [-250, 80],[-250, 40],[-170, 40],[-170,80], - [-100,80],[-100,40],[-20,40],[-20,80],[30,80], - [-10, 0],[-74, -10],[-110, -80]], - -corners_radius => [24,4, 40, 20, 0, 40, 40, 0, 0, 40, 40, 0, 30, 75, 0, 104], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundcurve1', - -linewidth => 2, - -linecolor => '#000000', - -priority => 30, - -tags => ['move'], - }, - -contours => [['add',-1,[[-240,-72],[-230,0],[-169,0],[-185, -72]], - 0, undef, [16, 16, 0, 0]], - ['add', -1, [[-175,-72],[-159,0],[-78,0],[-116, -72]], - 0, undef, [0, 0, 8, 88]], - ['add', 1, [[-245,45],[-245,115],[-175,115],[-175, 45]], - 35], - ['add', -1, [[-225,65],[-225,95],[-195,95],[-195, 65]], - 15], - ['add', 1, [[-95,45],[-95,115],[-25,115],[-25, 45]], - 35], - ['add', -1, [[-75,65],[-75,95],[-45,95],[-45, 65]], - 15], - ], - }, - 'mc3' => {-itemtype => 'roundedcurve', - -coords => [[-10, 170], [256, 170],[312, 60],[48, 60]], - -radius => 34, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundcurve2', - -linewidth => 2.5, - -linecolor => '#000000', - -priority => 40, - -tags => ['move'], - }, - -contours => [['add', -1, [[58, 62],[12, 144],[60, 172],[104, 88]],27], - ['add', 1, [[48, 77],[48, 119],[90, 119],[90, 77]],21], - ['add', -1, [[244, 58],[198, 140],[246, 168],[290, 84]],27], - ['add', 1, [[213, 110],[213, 152],[255, 152],[255, 110]],21], - ['add', -1, [[150, 60],[150, 170],[160, 170],[160, 60]],0]], - }, - 'mc4' => {-itemtype => 'roundedcurve', - -coords => [[222, -150],[138, -150],[180, -50],[138, -150], - [80, -92],[180, -50],[80, -92],[80, -8], - [180, -50],[80, -8],[138, 50],[180, -50], - [138, 50],[222, 50],[179.8, -50],[222, 50], - [280, -8],[180, -50],[280, -8],[280, -92], - [180, -50],[280, -92],[222,-150],[180,-50]], - -radius => 28, - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'roundcurve', - -linewidth => 2, - -linecolor => '#000000', - -priority => 30, - -tags => ['move'], - }, - -contours => [['add', -1, [[160, -70],[160, -30],[200, -30],[200, -70]],20]], - }, - }, - - 'TabBox' => {'consigne' => {-itemtype => 'text', - -coords => [-285, 160], - -params => {-font => $font_9b, - -text => "Click on thumbnail to select page\nChange anchor or alignment tabs options with radio buttons.\n", - -color => '#2222cc', - }, - }, - - 'exemple' => {-itemtype => 'text', - -coords => [-165, -105], - -params => {-font => $font_9b, - -text => "", - -alignment => 'left', - -anchor => 'nw', - -color => '#000000', - -priority => 500, - -width => 350, - -tags => ['div2', 'fontname'], - }, - }, - - 'bo1' => {-itemtype => 'tabbox', - -coords => [[-240, -160], [240, 100]], - -radius => 8, - -tabwidth => 72, - -tabheight => 28, - -numpages => 8, - -anchor => 'n', - -alignment => 'left', - -overlap => 3, - -params => {-closed => 1, - -priority => 100, - -filled => 1, - -fillcolor => '#ffffff', - -linewidth => 1.2, - -linecolor => '#000000', - -tags => ['div2', 'divider'], - }, - -tabtitles => {-text => ['A', 'B', 'C', 'D', 'E', 'F','G','H'], - -params => {-text => 'titre', - -color => '#2222cc', - -font => $font_9b, - -anchor => 'center', - -alignment => 'center', - -priority => 400, - -visible => 1, - }, - }, - }, - - 'back' => {-itemtype => 'roundedrectangle', - -coords => [[-242, -162], [242, 102]], - -radius => 10, - -params => {-closed => 1, - -filled => 1, - -fillcolor => '#777777;80', - -linewidth => 1, - -linecolor => '#777777;80', - }, - }, - - 'anchor' => {-itemtype => 'text', - -coords => [-120, 115], - -params => {-text => 'tabs anchor', - -color => '#2222cc', - -font => $font_9b, - -anchor => 'center', - -alignment => 'center', - -priority => 40, - }, - }, - - 'anchorN' => {-itemtype => 'hippodrome', - -coords => [[-210, 125], [-165, 151]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn4', - -linewidth => 1.5, - -linecolor => '#000000', - -priority => 20, - -tags => ['sel1','n','btn','selector'], - }, - -trunc => 'right', - }, - 'txtanN' => {-itemtype => 'text', - -coords => [-187, 138], - -params => {-text => 'N', - -color => '#000000', - -font => $font_9b, - -anchor => 'center', - -alignment => 'center', - -priority => 40, - -tags => ['sel1','n','btntext','selector'], - }, - }, - - 'anchorE' => {-itemtype => 'hippodrome', - -coords => [[-163, 125], [-120, 151]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn4', - -linewidth => 1.5, - -linecolor => '#000000', - -priority => 20, - -tags => ['sel1','e','btn','selector'], - }, - -trunc => 'both', - }, - 'txtanE' => {-itemtype => 'text', - -coords => [-141.5, 138], - -params => {-text => 'E', - -color => '#000000', - -font => $font_9b, - -anchor => 'center', - -alignment => 'center', - -priority => 40, - -tags => ['sel1','e','btntext','selector'], - }, - }, - - 'anchorS' => {-itemtype => 'hippodrome', - -coords => [[-118, 125], [-75, 151]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn4', - -linewidth => 1.5, - -linecolor => '#000000', - -priority => 20, - -tags => ['sel1','s','btn','selector'], - }, - -trunc => 'both', - }, - 'txtanS' => {-itemtype => 'text', - -coords => [-96.5, 138], - -params => {-text => 'S', - -color => '#000000', - -font => $font_9b, - -anchor => 'center', - -alignment => 'center', - -priority => 40, - -tags => ['sel1','s','btntext','selector'], - }, - }, - 'anchorW' => {-itemtype => 'hippodrome', - -coords => [[-73, 125], [-28, 151]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn4', - -linewidth => 1.5, - -linecolor => '#000000', - -priority => 20, - -tags => ['sel1','w','btn','selector'], - }, - -trunc => 'left', - }, - 'txtanW' => {-itemtype => 'text', - -coords => [-52, 138], - -params => {-text => 'W', - -color => '#000000', - -font => $font_9b, - -anchor => 'center', - -alignment => 'center', - -priority => 40, - -tags => ['sel1','w','btntext','selector'], - }, - }, - 'alignment' => {-itemtype => 'text', - -coords => [120, 115], - -params => {-text => 'tabs alignment', - -color => '#2222cc', - -font => $font_9b, - -anchor => 'center', - -alignment => 'center', - -priority => 40, - }, - }, - 'alignG' => {-itemtype => 'hippodrome', - -coords => [[30, 125], [90, 151]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn4', - -linewidth => 1.5, - -linecolor => '#000000', - -priority => 20, - -tags => ['sel2','left','btn','selector'], - }, - -trunc => 'right', - }, - 'txtalG' => {-itemtype => 'text', - -coords => [60, 138], - -params => {-text => 'left', - -color => '#000000', - -font => $font_9b, - -anchor => 'center', - -alignment => 'center', - -priority => 40, - -tags => ['sel2','left','btntext','selector'], - }, - }, - 'alignC' => {-itemtype => 'hippodrome', - -coords => [[92, 125], [148, 151]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn4', - -linewidth => 1.5, - -linecolor => '#000000', - -priority => 20, - -tags => ['sel2','center','btn','selector'], - }, - -trunc => 'both', - }, - 'txtalC' => {-itemtype => 'text', - -coords => [120, 138], - -params => {-text => 'center', - -color => '#000000', - -font => $font_9b, - -anchor => 'center', - -alignment => 'center', - -priority => 40, - -tags => ['sel2','center','btntext','selector'], - }, - }, - 'alignD' => {-itemtype => 'hippodrome', - -coords => [[150, 125], [210, 151]], - -params => {-closed => 1, - -filled => 1, - -fillcolor => 'pushbtn4', - -linewidth => 1.5, - -linecolor => '#000000', - -priority => 20, - -tags => ['sel2','right','btn','selector'], - }, - -trunc => 'left', - }, - 'txtalD' => {-itemtype => 'text', - -coords => [180, 138], - -params => {-text => 'right', - -color => '#000000', - -font => $font_9b, - -anchor => 'center', - -alignment => 'center', - -priority => 40, - -tags => ['sel2','right','btntext','selector'], - }, - }, - }, - - 'PathLine' => {'consigne' => {-itemtype => 'text', - -coords => [-285, 155], - -params => {-font => $font_9b, - -text => "Mouse button 1 drag objects,\nEscape key reset transfos.", - -color => '#2222cc', - }, - }, - 'pl1' => {-itemtype => 'pathline', - -metacoords => {-type => 'polygone', - -coords => [0, 0], - -numsides => 12, - -radius => 200, - -inner_radius => 100, - -startangle => -8, - }, - -linewidth => 20, - -closed => 1, - -graduate => {-type => 'linear', - -colors => ['#ff0000', '#ff00ff', '#0000ff', '#00ffff', - '#00ff00', '#ffff00', '#ff0000'], - }, - -params => {-priority => 100, - -tags => ['move'], - }, - }, - - 'pl2' => {-itemtype => 'group', - -coords => [0, 0], - -params => {-priority => 200, - -atomic => 1, - -tags => ['move'], - }, - -items => {'in' => {-itemtype => 'pathline', - -coords => [[30, -60],[-30, -60],[-30, -30], - [-60, -30],[-60, 30],[-30, 30], - [-30, 60],[30, 60],[30, 30], - [60, 30],[60, -30],[30, -30]], - -linewidth => 16, - -closed => 1, - -shifting => 'left', - -graduate => {-type => 'transversal', - -colors => ['#00aa77;100', '#00aa77;0'], - }, - -params => {-priority => 10, - }, - }, - - 'out' => {-itemtype => 'pathline', - -coords => [[30, -60],[-30, -60],[-30, -30], - [-60, -30],[-60, 30],[-30, 30], - [-30, 60],[30, 60],[30, 30], - [60, 30],[60, -30],[30, -30]], - -linewidth => 10, - -closed => 1, - -shifting => 'in', - -graduate => {-type => 'transversal', - -colors => ['#00aa77;100', '#00aa77;0'], - }, - -params => {-priority => 10, - }, - }, - }, - }, - - 'pl3' => {-itemtype => 'group', - -coords => [0, 0], - -params => {-priority => 100, - -atomic => 1, - -tags => ['move'], - }, - -items => {'back' => {-itemtype => 'arc', - -coords => [[-150, -150],[150,150]], - -params => {-priority => 10, - -closed => 1, - -filled => 1, - -fillcolor => '=radial 15 15|#ffffff;40|#aaaaff;10', - -linewidth => 0, - }, - }, - 'light' => {-itemtype => 'pathline', - -metacoords => {-type => 'polygone', - -coords => [0, 0], - -numsides => 30, - -radius => 150, - -startangle => 240, - }, - -linewidth => 20, - -shifting => 'in', - -closed => 1, - -graduate => {-type => 'double', - -colors => [['#ffffff;0', '#222299;0', '#ffffff;0'], - ['#ffffff;100', '#222299;70', '#ffffff;100']], - }, - -params => {-priority => 50, - }, - }, - 'bord' => {-itemtype => 'arc', - -coords => [[-150, -150],[150,150]], - -params => {-priority => 100, - -closed => 1, - -filled => 0, - -linewidth => 2, - -linecolor => '#000033;80' - }, - }, - - }, - }, - }, - - ); - -my %tabtable = ('n' => {-numpages => 8, - -titles => ['A','B','C','D','E','F','G','H'], - -names => ['ATOMIC GROUP :','BIND COMMAND :','CURVE ITEMS :','DISPLAY LIST :', - 'EVENTS SENSITIVITY :','FIT COMMAND :','GROUP ITEMS','HASTAG COMMAND'], - -texts => ["It may seem at first that there is a contradiction in this title, but there is not. [...] So groups have a feature, the atomic attribute, that is used to seal a group so that events cannot propagate past it downward. If an item part of an atomic group is under the pointer, TkZinc will try to trigger bindings associated with the atomic group not with the item under the pointer. This improves greatly the metaphor of an indivisible item.", - "This widget command is similar to the Tk bind command except that it operates on TkZinc items instead of widgets. Another difference with the bind command is that only mouse and keyboard related events can be specified (such as Enter, Leave, ButtonPress, ButtonRelease, Motion, KeyPress, KeyRelease). The bind manual page is the most accurate place to look for a definition of sequence and command and for a general understanding of how the binding mecanism works.", - "Items of type curve display pathes of line segments and/or cubic bezier connected by their end points. A cubic Bezier is defined by four points. The first and last ones are the extremities of the cubic Bezier. The second and the third ones are control point (i.e. they must have a third ``coordinate'' with the value 'c'). If both control points are identical, one may be omitted. As a consequence, it is an error to have more than two succcessive control points or to start or finish a curve with a control point.", - "The items are arranged in a display list for each group. The display list imposes a total ordering among its items. The group display lists are connected in a tree identical to the group tree and form a hierarchical display list. The items are drawn by traversing the display list from the least visible item to the most visible one.The search to find the item that should receive an event is done in the opposite direction. In this way, items are drawn according to their relative stacking order and events are dispatched to the top-most item at a given location.", - "An item will catch an event if all the following conditions are satisfied: * the item -sensitive must be set to true (this is the default). * the item must be under the pointer location. * the item must be on top of the display list (at the pointer location). Beware that an other item with its -visible set to false DOES catch event before any underneath items. * the item must not be clipped (at the pointer location) * the item must not belong to an atomic group, since an atomic group catchs the event instead of the item.", - "This command fits a sequence of Bezier segments on the curve described by the vertices in coordList and returns a list of lists describing the points and control points for the generated segments. All the points on the fitted segments will be within error distance from the given curve. coordList should be either a flat list of an even number of coordinates in x, y order or a list of lists of point coordinates X, Y. The returned list can be directly used to create or change a curve item contour.", - "Groups are very powerful items. They have no graphics of their own but are used to bundle items together so that they can be manipulated easily as a whole. Groups can modify in several way how items are displayed and how they react to events. They have many uses in TkZinc. The main usages are to bundle items, to interpose a new coordinate system in a hierarchy of items, to compose some specific attributes, to apply a clipping to their children items, to manage display", - "This command returns a boolean telling if the item specified by tagOrId has the specified tag. If more than one item is named by tagOrId, then the topmost in display list order is used to return the result. If no items are named by tagOrId, an error is raised.", - ], - }, - 'e' => {-numpages => 5, - -titles => ['I','J','K','L','M'], - -names => ['ITEM IDS','JOINSTYLE ATTRIBUTE','K :','LOWER COMMAND','MAP ITEM :'], - -texts => ["Each item is associated with a unique numerical id which is returned by the add or clone commands. All commands on items accept those ids as (often first) parameter in order to uniquely identify on which item they should operate. When an id has been allocated to an item, it is never collected even after the item has been destroyed, in a TkZinc session two items cannot have the same id. This property can be quite useful when used in conjonction with tags, which are described below.", - "Specifies the form of the joint between the curve segments. This attribute is only applicable if the curve outline relief is flat. The default value is round.", - "No TkZinc KeyWord with K initial letter...", - "Reorder all the items given by tagOrId so that they will be under the item given by belowThis. If tagOrId name more than one item, their relative order will be preserved. If tagOrId doesn't name an item, an error is raised. If belowThis name more than one item, the bottom most them is used. If belowThis doesn't name an item, an error is raised. If belowThis is omitted the items are put at the bottom most position of their respective groups.", - "Map items are typically used for displaying maps on a radar display view. Maps are not be sensitive to mouse or keyboard events, but have been designed to efficiently display large set of points, segments, arcs, and simple texts. A map item is associated to a mapinfo. This mapinfo entity can be either initialized with the videomap command or more generally created and edited with a set of commands described in the The mapinfo related commands section.", - ], - }, - 's' => {-numpages => 8, - -titles => ['N','O','P','Q','R','S','T','U'], - -names => ['NUMPARTS COMMAND :','OVERLAP MANAGER :','PICKAPERTURE WIDGET OPTION :','Q :', - 'RENDER WIDGET OPTION :','SMOOTH COMMAND','TAGS :', 'UNDERLINED ATTRIBUTE :'], - -texts => ["This command tells how many fieldId are available for event bindings or for field configuration commands in the item specified by tagOrId. If more than one item is named by tagOrId, the topmost in display list order is used to return the result. If no items are named by tagOrId, an error is raised. This command returns always 0 for items which do not support fields. The command hasfields may be used to decide whether an item has fields.", - "his option accepts an item id. It specifies if the label overlapping avoidance algorithm should be allowed to do its work on the track labels and which group should be considered to look for tracks. The default is to enable the avoidance algorithm in the root group (id 1). To disable the algorithm this option should be set to 0.", - "Specifies the size of an area around the pointer that is used to tell if the pointer is inside an item. This is useful to lessen the precision required when picking graphical elements. This value must be a positive integer. It defaults to 1.", - "No TkZinc KeyWord with Q initial letter...", - "Specifies whether to use or not the openGL rendering. When True, requires the GLX extension to the X server. Must be defined at widget creation time. This option is readonly and can be used to ask if the widget is drawing with the GLX extension or in plain X (to adapt the application code for example). The default value is false.", - "This command computes a sequence of Bezier segments that will smooth the polygon described by the vertices in coordList and returns a list of lists describing thr points and control points for the generated segments. coordList should be either a flat list of an even number of coordinates in x, y order, or a list of lists of point coordinates X, Y. The returned list can be used to create or change the contour of a curve item.", - "Apart from an id, an item can be associated with as many symbolic names as it may be needed by an application. Those names are called tags and can be any string which does not form a valid id (an integer). However the following characters may not be used to form a tag: . * ! ( ) & | :. Tags exists, and may be used in commands, even if no item are associated with them. In contrast an item id doesn't exist if its item is no longer around and thus it is illegal to use it.", - "Item Text attribute. If true, a thin line will be drawn under the text characters. The default value is false.", - ], - }, - 'w' => {-numpages => 5, - -titles => ['V','W','X','Y','Z'], - -names => ['VERTEXAT COMMAND :','WAYPOINT ITEM :','X11, OpenGL and Windows :','Y...','ZINC an advanced scriptable Canvas :'], - -texts => ["Return a list of values describing the vertex and edge closest to the window coordinates x and y in the item described by tagOrId. If tagOrId describes more than one item, the first item in display list order that supports vertex picking is used. The list consists of the index of the contour containing the returned vertices, the index of the closest vertex and the index of a vertex next to the closest vertex that identify the closest edge (located between the two returned vertices).", - "Waypoints items have been initially designed for figuring out typical fixed position objects (i.e. beacons or fixes in the ATC vocabulary) with associated block of texts on a radar display for Air Traffic Control. They supports mouse event handling and interactions. However they may certainly be used by other kinds of radar view or even by other kind of plan view with many geographical objects and associated textual information.", - "TkZinc was firstly designed for X11 server. 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 . In order to use the openGL features, you need the support of the GLX extension on your X11 server. We also succeeded in using TkZinc with openGL on the Exceed X11 server (running on windows and developped by Hummingbird) with the 3D extension. ", - "No TkZinc KeyWord with Y initial letter...", - "TkZinc widgets are very similar to Tk Canvases in that they support structured graphics. But unlike the Canvas, TkZinc can structure the items in a hierarchy, has support for affine 2D transforms, 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. If needed, it is also possible to extend the item set in an additionnal dynamic library through the use of a C api.", - ], - }, - ); - - -# creation de la fenetre principale -my $mw = MainWindow->new(); -$mw->geometry("700x560+0+0"); -$mw->title('Test Graphics Module'); - - -# creation du widget Zinc -my $zinc = $mw->Zinc(-render => 1, - -width => 700, - -height => 560, - -borderwidth => 0, - -lightangle => 140, - -borderwidth => 0, - -backcolor => '#cccccc',); -$zinc->pack(-fill => 'both', -expand => 1); - - -# initialise les gradients nommés -&setGradients($zinc, \%gradset); - -# création de la vue principale -my $tgroup = $zinc->add('group', 1); -$zinc->coords($tgroup, [350, 240]); - -# consigne globale -$zinc->add('text', 1, - -position => [50, 470], - -text => "Global interations :\n, , and keys move content of TabBox pages\n and keys zoom out and zoom in this page\n and keys rotate this page\n key reset transfos", - -font => $font_9b, - -color => '#555555', - -spacing => 2, - ); - -# Création des pages d'exemples -my ($shapes, $tcoords) = &tabBoxCoords([[-315, -210],[315, 210]], - -numpages => 7, - -overlap => 2, - -radius => 8, - -tabheight => 26, - -tabwidth => [92,100,82,82,82,120,80], - ); - -# to find some images (used as textures) needed by this demo -my $texture = $zinc->Photo('paper.gif', -file => Tk->findINC('demos/zinc_data/paper.gif')); - -# création des items zinc correspondants -my $i = scalar(@{$shapes}) - 1; -my @pagenames = ('Rectangle', 'Hippodrome', 'Polygone', 'Polyline', 'PathLine', 'MultiContours', 'TabBox'); -my @pagegroups; -foreach my $shape (reverse @{$shapes}) { - my $divgroup = $zinc->add('group', $tgroup); - - # création de l'intercalaire - my $divider = $zinc->add('curve', $divgroup, - $shape, - -closed => 1, - -priority => 10, - -linewidth => 1, - -linecolor => '#000000', - -filled => 1, - -tile => $texture, - -tags => ['div1', 'divider', $i, 'intercalaire'], - ); - - # groupe page clippé - my $page = $zinc->add('group', $divgroup, - -priority => 100, - -tags => ['div1', $i, 'page'], - ); - my $clip = $zinc->add('rectangle', $page, - [[-300, -170],[300, 195]], - -linewidth => 1, - -linecolor => '#000099', - -filled => 1, - -fillcolor => '#000000;4', - ); - $zinc->itemconfigure($page, -clip => $clip); - - my $pgroup = $zinc->add('group', $page, - -tags => ['div1', $i, 'content'], - ); - - push(@pagegroups, $pgroup); - - $tcoords->[$i]->[1] -= 6; - - # titre de l'intercalaire - $zinc->add('text', $divgroup, - -position => $tcoords->[$i], - -text => $pagenames[$i], - -font => $font_9b, - -alignment => 'center', - -anchor => 'n', - -color => '#000099', - -priority => 200, - -tags => ['div1', 'divider', $i, 'titre'], - ); - $i--; -} - -# création du contenu des pages -$i = 0; -foreach my $pagename (reverse @pagenames) { - my $pagestyle = $pagesconf{$pagename}; - if ($pagestyle) { - - my $pgroup = $pagegroups[$i]; - while (my ($itemname, $itemstyle) = each(%{$pagestyle})) { - my $group = ($itemname eq 'consigne') ? $zinc->group($pgroup) : $pgroup; - $itemstyle->{'-name'} = $itemname; - &buildZincItem($zinc, $group, %{$itemstyle}); - } - } - - $i++; -} - - -# initialisation de la TabBox -&clickSelector('sel1','n'); -&clickSelector('sel2','left'); -&selectDivider('div1', 0); - -# initialisation des bindings -&setBindings; - - -MainLoop; -#----------------------------------------------------------------------- fin de MAIN - - -sub setBindings { - # grab keyboard - $mw->Tk::focus(); - - # plus,moins : Zoom++, Zoom-- - $mw->Tk::bind('', sub {viewZoom('up');}); - $mw->Tk::bind('', sub {viewZoom('down');}); - - # Up, Down, Right, Left : Translate - $mw->Tk::bind('', sub {viewTranslate('up');}); - $mw->Tk::bind('', sub {viewTranslate('down');}); - $mw->Tk::bind('', sub {viewTranslate('left');}); - $mw->Tk::bind('', sub {viewTranslate('right');}); - - - # >, < : Rotate counterclockwise et clockwise - $mw->Tk::bind('', sub {viewRotate('cw');}); - $mw->Tk::bind('', sub {viewRotate('ccw');}); - - # Escape : reset transfos - $mw->Tk::bind('', sub {$zinc->treset('move'); - $zinc->raise('move'); - $zinc->treset($curview);}); - - $zinc->bind('divider', '<1>', sub {&selectDivider();}); - - $zinc->bind('selector', '<1>', sub {&clickSelector();}); - - $zinc->bind('move', '<1>', sub {&mobileStart();}); - $zinc->bind('move', '', sub {&mobileMove();}); - $zinc->bind('move', '', sub {&mobileStop();}); - - $zinc->bind('pushbtn', '<1>', sub {&pushButton();}); - $zinc->bind('pushbtn', '', sub {&pullButton();}); - - $zinc->bind('poly', '<1>', sub {&startRotatePolygone();}); - $zinc->bind('poly', '', sub {&rotatePolygone();}); -} - - -#----------------------------------------------------------------------------------- -# Callback sur evt CLICK des items tagés 'divider' -#----------------------------------------------------------------------------------- -sub selectDivider { - my ($divname, $numpage) = @_; - if (!defined $divname) { - my @tags = $zinc->itemcget('current', -tags); - $divname = $tags[0]; - $numpage = $tags[2]; - } - - $zinc->itemconfigure("($divname && titre)", -color => '#000099'); - $zinc->itemconfigure("($divname && intercalaire)", -linewidth => 1.4); - $zinc->itemconfigure("($divname && page)", -visible => 0); - - my $divgroup = $zinc->group("($divname && $numpage)"); - $zinc->raise($divgroup); - $curview = "($divname && $numpage && content)"; - $zinc->itemconfigure("($divname && $numpage && titre)", -color => '#000000'); - $zinc->itemconfigure("($divname && $numpage && intercalaire)", -linewidth => 2); - $zinc->itemconfigure("($divname && $numpage && page)", -visible => 1); - - if ($divname eq 'div2') { - my $fontname = $tabtable{$tabanchor}->{'-names'}->[$numpage]; - my $explain = $tabtable{$tabanchor}->{'-texts'}->[$numpage]; - my $text = $fontname."\n\n".$explain; - $zinc->itemconfigure("($divname && fontname)", - -text => $text); - $zinc->raise("($divname && fontname)"); - } -} - - -#----------------------------------------------------------------------------------- -# Callback sur evt CLICK des items tagés 'selector' -#----------------------------------------------------------------------------------- -sub clickSelector { - my ($btngroup, $value) = @_; - - if (!defined $btngroup and !defined $value) { - my @tags = $zinc->itemcget('current', -tags); - $btngroup = $tags[0]; - $value = $tags[1]; - } - - $zinc->treset($btngroup); - $zinc->itemconfigure("($btngroup && btntext)", -color => '#444444'); - $zinc->itemconfigure("($btngroup && $value && btntext)", -color => '#2222bb'); - $zinc->translate("($btngroup && $value)", 0, 1); - - if ($value eq 'n' or $value eq 'e' or $value eq 's' or $value eq 'w') { - $tabanchor = $value; - - } elsif ($value eq 'left' or $value eq 'center' or $value eq 'right') { - $tabalign = $value; - } - - my $tabtable = $tabtable{$tabanchor}; - my $numpages = $tabtable->{'-numpages'}; - my %tabparams = (-radius => 8, - -tabwidth => 72, - -tabheight => 28, - -numpages => $numpages, - -anchor => $tabanchor, - -alignment => $tabalign, - -overlap => 3, - ); - - my ($shapes, $tcoords) = &tabBoxCoords([[-240, -160], [240, 100]], %tabparams); - - for (my $index = 7; $index >= 0; $index--) { - my $divgroup = $zinc->group("(div2 && $index && intercalaire)"); - $zinc->itemconfigure($divgroup, -visible => ($index < $numpages)); - - if ($index >= $numpages) { - $zinc->lower($divgroup); - - } else { - $zinc->raise($divgroup); - $zinc->itemconfigure("(div2 && $index)", -visible => 1); - $zinc->coords("(div2 && $index && intercalaire)", $shapes->[$index]); - if ($zinc->type("(div2 && $index && titre)")) { - $zinc->coords("(div2 && $index && titre)", $tcoords->[$index]); - $zinc->itemconfigure("(div2 && $index && titre)", -text => $tabtable->{'-titles'}->[$index]); - } - } - - } - - &selectDivider('div2', 0); -} - - -#----------------------------------------------------------------------------------- -# Callback sur evt CLICK des items tagés 'pushbtn' -#----------------------------------------------------------------------------------- -sub pushButton { - my $tag = ($zinc->itemcget('current', -tags))[0]; - if (scalar $zinc->find('withtag', $tag) > 1 and - !$zinc->find('withtag', "($tag && ico)")) { - $tag = 'current'; - } - $zinc->scale($tag, .975, .975); - $zinc->translate($tag, 1, 1); - - if ($zinc->find('withtag', "($tag && ico)")) { - my $oldcolor = $zinc->itemcget("($tag && ico)", -fillcolor); - $zinc->itemconfigure('ico', -fillcolor => '#000000'); - - my $newcolor = ($oldcolor eq '#000000') ?'#ffff00' : '#000000'; - $zinc->itemconfigure("($tag && ico)", -fillcolor => $newcolor); - } -} - -#----------------------------------------------------------------------------------- -# Callback sur evt RELEASE des items tagés 'pushbtn' -#----------------------------------------------------------------------------------- -sub pullButton { - my $tag = ($zinc->itemcget('current', -tags))[0]; - $zinc->treset($tag); -} - - -#----------------------------------------------------------------------------------- -# Callback sur evt CATCH des items tagés 'poly' -# armement de rotation des polygones -#----------------------------------------------------------------------------------- -sub startRotatePolygone { - my $ev = $zinc->XEvent; - my ($xref, $yref) = $zinc->transform($zinc->group('current'), 1, [0, 0]); - $previousangle = &lineAngle([$ev->x, $ev->y], [$xref, $yref]); -} - -#----------------------------------------------------------------------------------- -# Callback sur evt MOTION des items tagés 'poly' -# rotation des polygones -#----------------------------------------------------------------------------------- -sub rotatePolygone { - my $tag = ($zinc->itemcget('current', -tags))[0]; - my $ev = $zinc->XEvent; - my ($xref, $yref) = $zinc->transform($zinc->group('current'), 1, [0, 0]); - my $newangle = &lineAngle([$ev->x, $ev->y], [$xref, $yref]); - - $zinc->rotate($tag, deg2rad($newangle - $previousangle)); - $previousangle = $newangle; -} - -#----------------------------------------------------------------------------------- -# Callback CATCH de sélection (début de déplacement) des items tagés 'move' -#----------------------------------------------------------------------------------- -sub mobileStart { - my $ev = $zinc->XEvent; - ($dx, $dy) = (0 - $ev->x, 0 - $ev->y); - - $zinc->raise('current'); - -} - - -#----------------------------------------------------------------------------------- -# Callback MOVE de déplacement des items tagés 'move' -#----------------------------------------------------------------------------------- -sub mobileMove { - my $ev = $zinc->XEvent; - $zinc->translate('current', $ev->x + $dx, $ev->y +$dy); - ($dx, $dy) = (0 - $ev->x, 0 - $ev->y); - -} - - -#----------------------------------------------------------------------------------- -# Callback RELEASE de relaché (fin de déplacement) des items tagés 'move' -#----------------------------------------------------------------------------------- -sub mobileStop { - &mobileMove; -} - - -#----------------------------------------------------------------------------------- -# Callback sur evénément Tk flèche gauche, haut, droite, bas -# pan (translation) du contenu de la page active (TabBox) -#----------------------------------------------------------------------------------- -sub viewTranslate { - my $way = shift; - - my $dx = ($way eq 'left') ? -10 : ($way eq 'right') ? 10 : 0; - my $dy = ($way eq 'up') ? -10 : ($way eq 'down') ? 10 : 0; - - $zinc->translate($curview, $dx, $dy); - -} - -#----------------------------------------------------------------------------------- -# Callback sur evénément Tk "+" ou "-" -# zoom du contenu de la page active (TabBox) -#----------------------------------------------------------------------------------- -sub viewZoom { - my $key = shift; - my $scaleratio = ($key eq 'up') ? 1+$zoomfactor : 1-$zoomfactor; - - $zinc->scale($curview, $scaleratio, $scaleratio); - -} - - -#----------------------------------------------------------------------------------- -# Callback sur evénément Tk ">" ou "<" -# rotation du contenu de la page active (TabBox) -#----------------------------------------------------------------------------------- -sub viewRotate { - my $way = shift; - my $delta_angle = $rotate_angle; - - $delta_angle *= -1 if ($way eq 'cw'); - - $zinc->rotate($curview, $delta_angle); - -} - - - -1; diff --git a/Perl/demos/Tk/demos/zinc_lib/textInput.pl b/Perl/demos/Tk/demos/zinc_lib/textInput.pl deleted file mode 100644 index 414f613..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/textInput.pl +++ /dev/null @@ -1,98 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# This simple demo has been developped by C. Mertz - -package textInput; # for avoiding symbol re-use between different demos - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - - -use Tk; -use Tk::Zinc; -use strict; - -use Tk::Zinc::Text; # the module for facilitating text input with zinc - -my $mw = MainWindow->new(); - -########################################### -# Text zone -########################################### - -my $text = $mw->Text(-relief => 'sunken', -borderwidth => 2, -height => 4); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', -'This toy-appli demonstrates the use of the -Tk::Zinc::Text module. This module is designed for -facilitating text input "a la emacs" on text items or on -fields of items such as tracks, waypoints or tabulars.'); - - -########################################### -# Zinc -########################################## -my $zinc = $mw->Zinc(-width => 500, -height => 300, - -font => "10x20", - -borderwidth => 3, -relief => 'sunken', - )->pack; - -Tk::Zinc::Text->new ($zinc); # for mapping text input bindings on item with a 'text' tag. - - -### creating a tabular with 3 fields, 2 of them being editable -my $labelformat1 = "130x100 x130x20+0+0 x130x20+0+20 x130x20+0+40"; - -my $x=120; -my $y=6; -my $track = $zinc->add('track',1, 3, - -position => [$x,$y], - -speedvector => [40, 10], - -labeldistance => 30, - -labelformat => $labelformat1, - -tags => 'text', - ); -# moving the track, to display past positions -foreach my $i (0..5) { $zinc->coords("$track",[$x+$i*10,$y+$i*2]); } - -$zinc->itemconfigure($track, 0, - -border => "contour", - -text => "not editable", - -sensitive => 0, - ); -$zinc->itemconfigure($track, 1, - -border => "contour", - -text => "editable", - -sensitive => 1, - ); -$zinc->itemconfigure($track, 2, - -border => "contour", - -text => "editable too", - -alignment => "center", - -sensitive => 1, - ); - -# creating a text item, tagged with 'text', but not editable because -# it is not sensitive -$zinc->add('text', 1, - -position => [220,160], - -text => "this text is not -editable because it is -not sensitive", - -sensitive => 0, - -tags => ['text'], - ); - -# creating an editable text item -$zinc->add('text', 1, - -position => [50,230], - -text => "this text IS -editable", - -sensitive => 1, - -tags => ['text'], - ); - - - -Tk::MainLoop; diff --git a/Perl/demos/Tk/demos/zinc_lib/tiger.pl b/Perl/demos/Tk/demos/zinc_lib/tiger.pl deleted file mode 100644 index 4972d39..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/tiger.pl +++ /dev/null @@ -1,554 +0,0 @@ -#!/usr/bin/perl -w - -# $Id$ -# This simple demo has been developped by C. Mertz - -####### This file has been initially generated from tiger.svg by SVG2zinc.pm Version: Revision: 1.10 -### the idea of using the shape extension (as possible with TkZinc -### under linux) was from Daniel Etienne! Thx! - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - - -use Tk::Zinc; -use Tk::Zinc::Debug; - -my $mw = MainWindow->new(); -$mw->title('tiger generated from svg file'); - -my ($WIDTH,$HEIGHT) = (600,600); -my $zinc = $mw->Zinc(-width => $WIDTH, -height => $HEIGHT, - -borderwidth => 0, - -backcolor => "grey90", - -render => 1, - -reshape => 1, - -fullreshape => 1, - )->pack; - - -&Tk::Zinc::Debug::init($zinc, - -optionsToDisplay => '-tags', - -optionsFormat => 'row', - ); - -my $top_group = $zinc->add('group', 1); - -$text = " -Drag-Button 1 for moving the tiger, -Drag-Button 2 for zooming the tiger, -Drag-Button 3 for rotating the tiger, -esc for getting help on Tk::Zinc::Debug functions. -"; - -my $clip= $zinc->add('curve',1, - [ [0,150], [150,0], [470,20], [580, 200], [600,300], [500,560], [50,550], [10,450] ], - -closed => 1, -visible => 0); - -$zinc->itemconfigure(1, -clip => $clip); - -$zinc->add('text', 1, -position => [51,521], -anchor => 'w', - -priority => 20, -text => $text, -color => "white"); -$zinc->add('text', 1, -position => [50,520], -anchor => 'w', - -priority => 20, -text => $text, -color => "black"); - -$zinc->add('curve',$top_group,[[122.304, 84.285], [-122.304, 84.285, 'c'], [-122.203, 86.179, 'c'], [-123.027, 86.16], [-123.851, 86.141, 'c'], [-140.305, 38.066, 'c'], [-160.833, 40.309], [-160.833, 40.309, 'c'], [-143.05, 32.956, 'c'], [-122.304, 84.285]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.172); -$zinc->add('curve',$top_group,[[118.774, 81.262], [-118.774, 81.262, 'c'], [-119.323, 83.078, 'c'], [-120.092, 82.779], [-120.86, 82.481, 'c'], [-119.977, 31.675, 'c'], [-140.043, 26.801], [-140.043, 26.801, 'c'], [-120.82, 25.937, 'c'], [-118.774, 81.262]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.172); -$zinc->add('curve',$top_group,[[91.284, 123.59], [-91.284, 123.59, 'c'], [-89.648, 124.55, 'c'], [-90.118, 125.227], [-90.589, 125.904, 'c'], [-139.763, 113.102, 'c'], [-149.218, 131.459], [-149.218, 131.459, 'c'], [-145.539, 112.572, 'c'], [-91.284, 123.59]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.172); -$zinc->add('curve',$top_group,[[94.093, 133.801], [-94.093, 133.801, 'c'], [-92.237, 134.197, 'c'], [-92.471, 134.988], [-92.704, 135.779, 'c'], [-143.407, 139.121, 'c'], [-146.597, 159.522], [-146.597, 159.522, 'c'], [-149.055, 140.437, 'c'], [-94.093, 133.801]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.172); -$zinc->add('curve',$top_group,[[98.304, 128.276], [-98.304, 128.276, 'c'], [-96.526, 128.939, 'c'], [-96.872, 129.687], [-97.218, 130.435, 'c'], [-147.866, 126.346, 'c'], [-153.998, 146.064], [-153.998, 146.064, 'c'], [-153.646, 126.825, 'c'], [-98.304, 128.276]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.172); -$zinc->add('curve',$top_group,[[109.009, 110.072], [-109.009, 110.072, 'c'], [-107.701, 111.446, 'c'], [-108.34, 111.967], [-108.979, 112.488, 'c'], [-152.722, 86.634, 'c'], [-166.869, 101.676], [-166.869, 101.676, 'c'], [-158.128, 84.533, 'c'], [-109.009, 110.072]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.172); -$zinc->add('curve',$top_group,[[116.554, 114.263], [-116.554, 114.263, 'c'], [-115.098, 115.48, 'c'], [-115.674, 116.071], [-116.25, 116.661, 'c'], [-162.638, 95.922, 'c'], [-174.992, 112.469], [-174.992, 112.469, 'c'], [-168.247, 94.447, 'c'], [-116.554, 114.263]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.172); -$zinc->add('curve',$top_group,[[119.154, 118.335], [-119.154, 118.335, 'c'], [-117.546, 119.343, 'c'], [-118.036, 120.006], [-118.526, 120.669, 'c'], [-167.308, 106.446, 'c'], [-177.291, 124.522], [-177.291, 124.522, 'c'], [-173.066, 105.749, 'c'], [-119.154, 118.335]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.172); -$zinc->add('curve',$top_group,[[108.42, 118.949], [-108.42, 118.949, 'c'], [-107.298, 120.48, 'c'], [-107.999, 120.915], [-108.7, 121.35, 'c'], [-148.769, 90.102, 'c'], [-164.727, 103.207], [-164.727, 103.207, 'c'], [-153.862, 87.326, 'c'], [-108.42, 118.949]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.172); -$zinc->add('curve',$top_group,[[128.2, 90], [-128.2, 90, 'c'], [-127.6, 91.8, 'c'], [-128.4, 92], [-129.2, 92.2, 'c'], [-157.8, 50.2, 'c'], [-177.001, 57.8], [-177.001, 57.8, 'c'], [-161.8, 46, 'c'], [-128.2, 90]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.172); -$zinc->add('curve',$top_group,[[127.505, 96.979], [-127.505, 96.979, 'c'], [-126.53, 98.608, 'c'], [-127.269, 98.975], [-128.007, 99.343, 'c'], [-164.992, 64.499, 'c'], [-182.101, 76.061], [-182.101, 76.061, 'c'], [-169.804, 61.261, 'c'], [-127.505, 96.979]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.172); -$zinc->add('curve',$top_group,[[127.62, 101.349], [-127.62, 101.349, 'c'], [-126.498, 102.88, 'c'], [-127.199, 103.315], [-127.9, 103.749, 'c'], [-167.969, 72.502, 'c'], [-183.927, 85.607], [-183.927, 85.607, 'c'], [-173.062, 69.726, 'c'], [-127.62, 101.349]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.172); -$zinc->add('curve',$top_group,[[129.83, 103.065], [-129.327, 109.113, 'c'], [-128.339, 115.682, 'c'], [-126.6, 118.801], [-126.6, 118.801, 'c'], [-130.2, 131.201, 'c'], [-121.4, 144.401], [-121.4, 144.401, 'c'], [-121.8, 151.601, 'c'], [-120.2, 154.801], [-120.2, 154.801, 'c'], [-116.2, 163.201, 'c'], [-111.4, 164.001], [-107.516, 164.648, 'c'], [-98.793, 167.717, 'c'], [-88.932, 169.121], [-88.932, 169.121, 'c'], [-71.8, 183.201, 'c'], [-75, 196.001], [-75, 196.001, 'c'], [-75.4, 212.401, 'c'], [-79, 214.001], [-79, 214.001, 'c'], [-67.4, 202.801, 'c'], [-77, 219.601], [-81.4, 238.401], [-81.4, 238.401, 'c'], [-55.8, 216.801, 'c'], [-71.4, 235.201], [-81.4, 261.201], [-81.4, 261.201, 'c'], [-61.8, 242.801, 'c'], [-69, 251.201], [-72.2, 260.001], [-72.2, 260.001, 'c'], [-29, 232.801, 'c'], [-59.8, 262.401], [-59.8, 262.401, 'c'], [-51.8, 258.801, 'c'], [-47.4, 261.601], [-47.4, 261.601, 'c'], [-40.6, 260.401, 'c'], [-41.4, 262.001], [-41.4, 262.001, 'c'], [-62.2, 272.401, 'c'], [-65.8, 290.801], [-65.8, 290.801, 'c'], [-57.4, 280.801, 'c'], [-60.6, 291.601], [-60.2, 303.201], [-60.2, 303.201, 'c'], [-56.2, 281.601, 'c'], [-56.6, 319.201], [-56.6, 319.201, 'c'], [-37.4, 301.201, 'c'], [-49, 322.001], [-49, 338.801], [-49, 338.801, 'c'], [-33.8, 322.401, 'c'], [-40.2, 335.201], [-40.2, 335.201, 'c'], [-30.2, 326.401, 'c'], [-34.2, 341.601], [-34.2, 341.601, 'c'], [-35, 352.001, 'c'], [-30.6, 340.801], [-30.6, 340.801, 'c'], [-14.6, 310.201, 'c'], [-20.6, 336.401], [-20.6, 336.401, 'c'], [-21.4, 355.601, 'c'], [-16.6, 340.801], [-16.6, 340.801, 'c'], [-16.2, 351.201, 'c'], [-7, 358.401], [-7, 358.401, 'c'], [-8.2, 307.601, 'c'], [4.6, 343.601], [8.6, 360.001], [8.6, 360.001, 'c'], [11.4, 350.801, 'c'], [11, 345.601], [11, 345.601, 'c'], [25.8, 329.201, 'c'], [19, 353.601], [19, 353.601, 'c'], [34.2, 330.801, 'c'], [31, 344.001], [31, 344.001, 'c'], [23.4, 360.001, 'c'], [25, 364.801], [25, 364.801, 'c'], [41.8, 330.001, 'c'], [43, 328.401], [43, 328.401, 'c'], [41, 370.802, 'c'], [51.8, 334.801], [51.8, 334.801, 'c'], [57.4, 346.801, 'c'], [54.6, 351.201], [54.6, 351.201, 'c'], [62.6, 343.201, 'c'], [61.8, 340.001], [61.8, 340.001, 'c'], [66.4, 331.801, 'c'], [69.2, 345.401], [69.2, 345.401, 'c'], [71, 354.801, 'c'], [72.6, 351.601], [72.6, 351.601, 'c'], [76.6, 375.602, 'c'], [77.8, 352.801], [77.8, 352.801, 'c'], [79.4, 339.201, 'c'], [72.2, 327.601], [72.2, 327.601, 'c'], [73, 324.401, 'c'], [70.2, 320.401], [70.2, 320.401, 'c'], [83.8, 342.001, 'c'], [76.6, 313.201], [76.6, 313.201, 'c'], [87.801, 321.201, 'c'], [89.001, 321.201], [89.001, 321.201, 'c'], [75.4, 298.001, 'c'], [84.2, 302.801], [84.2, 302.801, 'c'], [79, 292.401, 'c'], [97.001, 304.401], [97.001, 304.401, 'c'], [81, 288.401, 'c'], [98.601, 298.001], [98.601, 298.001, 'c'], [106.601, 304.401, 'c'], [99.001, 294.401], [99.001, 294.401, 'c'], [84.6, 278.401, 'c'], [106.601, 296.401], [106.601, 296.401, 'c'], [118.201, 312.801, 'c'], [119.001, 315.601], [119.001, 315.601, 'c'], [109.001, 286.401, 'c'], [104.601, 283.601], [104.601, 283.601, 'c'], [113.001, 247.201, 'c'], [154.201, 262.801], [154.201, 262.801, 'c'], [161.001, 280.001, 'c'], [165.401, 261.601], [165.401, 261.601, 'c'], [178.201, 255.201, 'c'], [189.401, 282.801], [189.401, 282.801, 'c'], [193.401, 269.201, 'c'], [192.601, 266.401], [192.601, 266.401, 'c'], [199.401, 267.601, 'c'], [198.601, 266.401], [198.601, 266.401, 'c'], [211.801, 270.801, 'c'], [213.001, 270.001], [213.001, 270.001, 'c'], [219.801, 276.801, 'c'], [220.201, 273.201], [220.201, 273.201, 'c'], [229.401, 276.001, 'c'], [227.401, 272.401], [227.401, 272.401, 'c'], [236.201, 288.001, 'c'], [236.601, 291.601], [239.001, 277.601], [241.001, 280.401], [241.001, 280.401, 'c'], [242.601, 272.801, 'c'], [241.801, 271.601], [241.001, 270.401, 'c'], [261.801, 278.401, 'c'], [266.601, 299.201], [268.601, 307.601], [268.601, 307.601, 'c'], [274.601, 292.801, 'c'], [273.001, 288.801], [273.001, 288.801, 'c'], [278.201, 289.601, 'c'], [278.601, 294.001], [278.601, 294.001, 'c'], [282.601, 270.801, 'c'], [277.801, 264.801], [277.801, 264.801, 'c'], [282.201, 264.001, 'c'], [283.401, 267.601], [283.401, 260.401], [283.401, 260.401, 'c'], [290.601, 261.201, 'c'], [290.601, 258.801], [290.601, 258.801, 'c'], [295.001, 254.801, 'c'], [297.001, 259.601], [297.001, 259.601, 'c'], [284.601, 224.401, 'c'], [303.001, 243.601], [303.001, 243.601, 'c'], [310.201, 254.401, 'c'], [306.601, 235.601], [303.001, 216.801, 'c'], [299.001, 215.201, 'c'], [303.801, 214.801], [303.801, 214.801, 'c'], [304.601, 211.201, 'c'], [302.601, 209.601], [300.601, 208.001, 'c'], [303.801, 209.601, 'c'], [303.801, 209.601], [303.801, 209.601, 'c'], [308.601, 213.601, 'c'], [303.401, 191.601], [303.401, 191.601, 'c'], [309.801, 193.201, 'c'], [297.801, 164.001], [297.801, 164.001, 'c'], [300.601, 161.601, 'c'], [296.601, 153.201], [296.601, 153.201, 'c'], [304.601, 157.601, 'c'], [307.401, 156.001], [307.401, 156.001, 'c'], [307.001, 154.401, 'c'], [303.801, 150.401], [303.801, 150.401, 'c'], [282.201, 95.6, 'c'], [302.601, 117.601], [302.601, 117.601, 'c'], [314.451, 131.151, 'c'], [308.051, 108.351], [308.051, 108.351, 'c'], [298.94, 84.341, 'c'], [299.717, 80.045], [-129.83, 103.065]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1); -$zinc->add('curve',$top_group,[[299.717, 80.245], [300.345, 80.426, 'c'], [302.551, 81.55, 'c'], [303.801, 83.2], [303.801, 83.2, 'c'], [310.601, 94, 'c'], [305.401, 75.6], [305.401, 75.6, 'c'], [296.201, 46.8, 'c'], [305.001, 58], [305.001, 58, 'c'], [311.001, 65.2, 'c'], [307.801, 51.6], [303.936, 35.173, 'c'], [301.401, 28.8, 'c'], [301.401, 28.8], [301.401, 28.8, 'c'], [313.001, 33.6, 'c'], [286.201, -6], [295.001, -2.4], [295.001, -2.4, 'c'], [275.401, -42, 'c'], [253.801, -47.2], [245.801, -53.2], [245.801, -53.2, 'c'], [284.201, -91.2, 'c'], [271.401, -128], [271.401, -128, 'c'], [264.601, -133.2, 'c'], [255.001, -124], [255.001, -124, 'c'], [248.601, -119.2, 'c'], [242.601, -120.8], [242.601, -120.8, 'c'], [211.801, -119.6, 'c'], [209.801, -119.6], [207.801, -119.6, 'c'], [173.001, -156.8, 'c'], [107.401, -139.2], [107.401, -139.2, 'c'], [102.201, -137.2, 'c'], [97.801, -138.4], [97.801, -138.4, 'c'], [79.4, -154.4, 'c'], [30.6, -131.6], [30.6, -131.6, 'c'], [20.6, -129.6, 'c'], [19, -129.6], [17.4, -129.6, 'c'], [14.6, -129.6, 'c'], [6.6, -123.2], [-1.4, -116.8, 'c'], [-1.8, -116, 'c'], [-3.8, -114.4], [-3.8, -114.4, 'c'], [-20.2, -103.2, 'c'], [-25, -102.4], [-25, -102.4, 'c'], [-36.6, -96, 'c'], [-41, -86], [-44.6, -84.8], [-44.6, -84.8, 'c'], [-46.2, -77.6, 'c'], [-46.6, -76.4], [-46.6, -76.4, 'c'], [-51.4, -72.8, 'c'], [-52.2, -67.2], [-52.2, -67.2, 'c'], [-61, -61.2, 'c'], [-60.6, -56.8], [-60.6, -56.8, 'c'], [-62.2, -51.6, 'c'], [-63, -46.8], [-63, -46.8, 'c'], [-70.2, -42, 'c'], [-69.4, -39.2], [-69.4, -39.2, 'c'], [-77, -25.2, 'c'], [-75.8, -18.4], [-75.8, -18.4, 'c'], [-82.2, -18.8, 'c'], [-85, -16.4], [-85, -16.4, 'c'], [-85.8, -11.6, 'c'], [-87.4, -11.2], [-87.4, -11.2, 'c'], [-90.2, -10, 'c'], [-87.8, -6], [-87.8, -6, 'c'], [-89.4, -3.2, 'c'], [-89.8, -1.6], [-89.8, -1.6, 'c'], [-89, 1.2, 'c'], [-93.4, 6.8], [-93.4, 6.8, 'c'], [-99.8, 25.6, 'c'], [-97.8, 30.8], [-97.8, 30.8, 'c'], [-97.4, 35.6, 'c'], [-100.2, 37.2], [-100.2, 37.2, 'c'], [-103.8, 36.8, 'c'], [-95.4, 48.8], [-95.4, 48.8, 'c'], [-94.6, 50, 'c'], [-97.8, 52.4], [-97.8, 52.4, 'c'], [-115, 56, 'c'], [-117.4, 72.4], [-117.4, 72.4, 'c'], [-131, 87.2, 'c'], [-131, 92.4], [-131, 94.705, 'c'], [-130.729, 97.852, 'c'], [-130.03, 102.465], [-130.03, 102.465, 'c'], [-130.6, 110.801, 'c'], [-103, 111.601], [-75.4, 112.401, 'c'], [299.717, 80.245, 'c'], [299.717, 80.245]], -closed => 1, -linecolor => "#000000", -fillcolor => "#cc7226", -filled => 1); - -$zinc->add('curve',$top_group,[[115.6, 102.6], [-140.6, 63.2, 'c'], [-126.2, 119.601, 'c'], [-126.2, 119.601], [-117.4, 154.001, 'c'], [12.2, 116.401, 'c'], [12.2, 116.401], [12.2, 116.401, 'c'], [181.001, 86, 'c'], [192.201, 82], [203.401, 78, 'c'], [298.601, 84.4, 'c'], [298.601, 84.4], [293.001, 67.6], [228.201, 21.2, 'c'], [209.001, 44.4, 'c'], [195.401, 40.4], [181.801, 36.4, 'c'], [184.201, 46, 'c'], [181.001, 46.8], [177.801, 47.6, 'c'], [138.601, 22.8, 'c'], [132.201, 23.6], [125.801, 24.4, 'c'], [100.459, 0.649, 'c'], [115.401, 32.4], [131.401, 66.4, 'c'], [57, 71.6, 'c'], [40.2, 60.4], [23.4, 49.2, 'c'], [47.4, 78.8, 'c'], [47.4, 78.8], [65.8, 98.8, 'c'], [31.4, 82, 'c'], [31.4, 82], [-3, 69.2, 'c'], [-27, 94.8, 'c'], [-30.2, 95.6], [-33.4, 96.4, 'c'], [-38.2, 99.6, 'c'], [-39, 93.2], [-39.8, 86.8, 'c'], [-47.31, 70.099, 'c'], [-79, 96.4], [-99, 113.001, 'c'], [-112.8, 91, 'c'], [-112.8, 91], [-115.6, 102.6]], -closed => 1, -fillcolor => "#cc7226", -filled => 1, -linecolor => "#cc7226"); -$zinc->add('curve',$top_group,[[133.51, 25.346], [127.11, 26.146, 'c'], [101.743, 2.407, 'c'], [116.71, 34.146], [133.31, 69.346, 'c'], [58.31, 73.346, 'c'], [41.51, 62.146], [24.709, 50.946, 'c'], [48.71, 80.546, 'c'], [48.71, 80.546], [67.11, 100.546, 'c'], [32.709, 83.746, 'c'], [32.709, 83.746], [-1.691, 70.946, 'c'], [-25.691, 96.546, 'c'], [-28.891, 97.346], [-32.091, 98.146, 'c'], [-36.891, 101.346, 'c'], [-37.691, 94.946], [-38.491, 88.546, 'c'], [-45.87, 72.012, 'c'], [-77.691, 98.146], [-98.927, 115.492, 'c'], [-112.418, 94.037, 'c'], [-112.418, 94.037], [-115.618, 104.146], [-140.618, 64.346, 'c'], [-125.546, 122.655, 'c'], [-125.546, 122.655], [-116.745, 157.056, 'c'], [13.509, 118.146, 'c'], [13.509, 118.146], [13.509, 118.146, 'c'], [182.31, 87.746, 'c'], [193.51, 83.746], [204.71, 79.746, 'c'], [299.038, 86.073, 'c'], [299.038, 86.073], [293.51, 68.764], [228.71, 22.364, 'c'], [210.31, 46.146, 'c'], [196.71, 42.146], [183.11, 38.146, 'c'], [185.51, 47.746, 'c'], [182.31, 48.546], [179.11, 49.346, 'c'], [139.91, 24.546, 'c'], [133.51, 25.346]], -closed => 1, -fillcolor => "#e87f3a", -filled => 1, -linecolor => "#e87f3a"); -$zinc->add('curve',$top_group,[[134.819, 27.091], [128.419, 27.891, 'c'], [103.685, 3.862, 'c'], [118.019, 35.891], [134.219, 72.092, 'c'], [59.619, 75.092, 'c'], [42.819, 63.892], [26.019, 52.692, 'c'], [50.019, 82.292, 'c'], [50.019, 82.292], [68.419, 102.292, 'c'], [34.019, 85.492, 'c'], [34.019, 85.492], [-0.381, 72.692, 'c'], [-24.382, 98.292, 'c'], [-27.582, 99.092], [-30.782, 99.892, 'c'], [-35.582, 103.092, 'c'], [-36.382, 96.692], [-37.182, 90.292, 'c'], [-44.43, 73.925, 'c'], [-76.382, 99.892], [-98.855, 117.983, 'c'], [-112.036, 97.074, 'c'], [-112.036, 97.074], [-115.636, 105.692], [-139.436, 66.692, 'c'], [-124.891, 125.71, 'c'], [-124.891, 125.71], [-116.091, 160.11, 'c'], [14.819, 119.892, 'c'], [14.819, 119.892], [14.819, 119.892, 'c'], [183.619, 89.492, 'c'], [194.819, 85.492], [206.019, 81.492, 'c'], [299.474, 87.746, 'c'], [299.474, 87.746], [294.02, 69.928], [229.219, 23.528, 'c'], [211.619, 47.891, 'c'], [198.019, 43.891], [184.419, 39.891, 'c'], [186.819, 49.491, 'c'], [183.619, 50.292], [180.419, 51.092, 'c'], [141.219, 26.291, 'c'], [134.819, 27.091]], -closed => 1, -fillcolor => "#ea8c4d", -filled => 1, -linecolor => "#ea8c4d"); -$zinc->add('curve',$top_group,[[136.128, 28.837], [129.728, 29.637, 'c'], [104.999, 5.605, 'c'], [119.328, 37.637], [136.128, 75.193, 'c'], [60.394, 76.482, 'c'], [44.128, 65.637], [27.328, 54.437, 'c'], [51.328, 84.037, 'c'], [51.328, 84.037], [69.728, 104.037, 'c'], [35.328, 87.237, 'c'], [35.328, 87.237], [0.928, 74.437, 'c'], [-23.072, 100.037, 'c'], [-26.272, 100.837], [-29.472, 101.637, 'c'], [-34.272, 104.837, 'c'], [-35.072, 98.437], [-35.872, 92.037, 'c'], [-42.989, 75.839, 'c'], [-75.073, 101.637], [-98.782, 120.474, 'c'], [-111.655, 100.11, 'c'], [-111.655, 100.11], [-115.655, 107.237], [-137.455, 70.437, 'c'], [-124.236, 128.765, 'c'], [-124.236, 128.765], [-115.436, 163.165, 'c'], [16.128, 121.637, 'c'], [16.128, 121.637], [16.128, 121.637, 'c'], [184.928, 91.237, 'c'], [196.129, 87.237], [207.329, 83.237, 'c'], [299.911, 89.419, 'c'], [299.911, 89.419], [294.529, 71.092], [229.729, 24.691, 'c'], [212.929, 49.637, 'c'], [199.329, 45.637], [185.728, 41.637, 'c'], [188.128, 51.237, 'c'], [184.928, 52.037], [181.728, 52.837, 'c'], [142.528, 28.037, 'c'], [136.128, 28.837]], -closed => 1, -fillcolor => "#ec9961", -filled => 1, -linecolor => "#ec9961"); -$zinc->add('curve',$top_group,[[137.438, 30.583], [131.037, 31.383, 'c'], [106.814, 7.129, 'c'], [120.637, 39.383], [137.438, 78.583, 'c'], [62.237, 78.583, 'c'], [45.437, 67.383], [28.637, 56.183, 'c'], [52.637, 85.783, 'c'], [52.637, 85.783], [71.037, 105.783, 'c'], [36.637, 88.983, 'c'], [36.637, 88.983], [2.237, 76.183, 'c'], [-21.763, 101.783, 'c'], [-24.963, 102.583], [-28.163, 103.383, 'c'], [-32.963, 106.583, 'c'], [-33.763, 100.183], [-34.563, 93.783, 'c'], [-41.548, 77.752, 'c'], [-73.763, 103.383], [-98.709, 122.965, 'c'], [-111.273, 103.146, 'c'], [-111.273, 103.146], [-115.673, 108.783], [-135.473, 73.982, 'c'], [-123.582, 131.819, 'c'], [-123.582, 131.819], [-114.782, 166.22, 'c'], [17.437, 123.383, 'c'], [17.437, 123.383], [17.437, 123.383, 'c'], [186.238, 92.983, 'c'], [197.438, 88.983], [208.638, 84.983, 'c'], [300.347, 91.092, 'c'], [300.347, 91.092], [295.038, 72.255], [230.238, 25.855, 'c'], [214.238, 51.383, 'c'], [200.638, 47.383], [187.038, 43.383, 'c'], [189.438, 52.983, 'c'], [186.238, 53.783], [183.038, 54.583, 'c'], [143.838, 29.783, 'c'], [137.438, 30.583]], -closed => 1, -fillcolor => "#eea575", -filled => 1, -linecolor => "#eea575"); -$zinc->add('curve',$top_group,[[138.747, 32.328], [132.347, 33.128, 'c'], [106.383, 9.677, 'c'], [121.947, 41.128], [141.147, 79.928, 'c'], [63.546, 80.328, 'c'], [46.746, 69.128], [29.946, 57.928, 'c'], [53.946, 87.528, 'c'], [53.946, 87.528], [72.346, 107.528, 'c'], [37.946, 90.728, 'c'], [37.946, 90.728], [3.546, 77.928, 'c'], [-20.454, 103.528, 'c'], [-23.654, 104.328], [-26.854, 105.128, 'c'], [-31.654, 108.328, 'c'], [-32.454, 101.928], [-33.254, 95.528, 'c'], [-40.108, 79.665, 'c'], [-72.454, 105.128], [-98.636, 125.456, 'c'], [-110.891, 106.183, 'c'], [-110.891, 106.183], [-115.691, 110.328], [-133.691, 77.128, 'c'], [-122.927, 134.874, 'c'], [-122.927, 134.874], [-114.127, 169.274, 'c'], [18.746, 125.128, 'c'], [18.746, 125.128], [18.746, 125.128, 'c'], [187.547, 94.728, 'c'], [198.747, 90.728], [209.947, 86.728, 'c'], [300.783, 92.764, 'c'], [300.783, 92.764], [295.547, 73.419], [230.747, 27.019, 'c'], [215.547, 53.128, 'c'], [201.947, 49.128], [188.347, 45.128, 'c'], [190.747, 54.728, 'c'], [187.547, 55.528], [184.347, 56.328, 'c'], [145.147, 31.528, 'c'], [138.747, 32.328]], -closed => 1, -fillcolor => "#f1b288", -filled => 1, -linecolor => "#f1b288"); -$zinc->add('curve',$top_group,[[140.056, 34.073], [133.655, 34.873, 'c'], [107.313, 11.613, 'c'], [123.255, 42.873], [143.656, 82.874, 'c'], [64.855, 82.074, 'c'], [48.055, 70.874], [31.255, 59.674, 'c'], [55.255, 89.274, 'c'], [55.255, 89.274], [73.655, 109.274, 'c'], [39.255, 92.474, 'c'], [39.255, 92.474], [4.855, 79.674, 'c'], [-19.145, 105.274, 'c'], [-22.345, 106.074], [-25.545, 106.874, 'c'], [-30.345, 110.074, 'c'], [-31.145, 103.674], [-31.945, 97.274, 'c'], [-38.668, 81.578, 'c'], [-71.145, 106.874], [-98.564, 127.947, 'c'], [-110.509, 109.219, 'c'], [-110.509, 109.219], [-115.709, 111.874], [-131.709, 81.674, 'c'], [-122.273, 137.929, 'c'], [-122.273, 137.929], [-113.473, 172.329, 'c'], [20.055, 126.874, 'c'], [20.055, 126.874], [20.055, 126.874, 'c'], [188.856, 96.474, 'c'], [200.056, 92.474], [211.256, 88.474, 'c'], [301.22, 94.437, 'c'], [301.22, 94.437], [296.056, 74.583], [231.256, 28.183, 'c'], [216.856, 54.874, 'c'], [203.256, 50.874], [189.656, 46.873, 'c'], [192.056, 56.474, 'c'], [188.856, 57.274], [185.656, 58.074, 'c'], [146.456, 33.273, 'c'], [140.056, 34.073]], -closed => 1, -fillcolor => "#f3bf9c", -filled => 1, -linecolor => "#f3bf9c"); -$zinc->add('curve',$top_group,[[141.365, 35.819], [134.965, 36.619, 'c'], [107.523, 13.944, 'c'], [124.565, 44.619], [146.565, 84.219, 'c'], [66.164, 83.819, 'c'], [49.364, 72.619], [32.564, 61.419, 'c'], [56.564, 91.019, 'c'], [56.564, 91.019], [74.964, 111.019, 'c'], [40.564, 94.219, 'c'], [40.564, 94.219], [6.164, 81.419, 'c'], [-17.836, 107.019, 'c'], [-21.036, 107.819], [-24.236, 108.619, 'c'], [-29.036, 111.819, 'c'], [-29.836, 105.419], [-30.636, 99.019, 'c'], [-37.227, 83.492, 'c'], [-69.836, 108.619], [-98.491, 130.438, 'c'], [-110.127, 112.256, 'c'], [-110.127, 112.256], [-115.727, 113.419], [-130.128, 85.019, 'c'], [-121.618, 140.983, 'c'], [-121.618, 140.983], [-112.818, 175.384, 'c'], [21.364, 128.619, 'c'], [21.364, 128.619], [21.364, 128.619, 'c'], [190.165, 98.219, 'c'], [201.365, 94.219], [212.565, 90.219, 'c'], [301.656, 96.11, 'c'], [301.656, 96.11], [296.565, 75.746], [231.765, 29.346, 'c'], [218.165, 56.619, 'c'], [204.565, 52.619], [190.965, 48.619, 'c'], [193.365, 58.219, 'c'], [190.165, 59.019], [186.965, 59.819, 'c'], [147.765, 35.019, 'c'], [141.365, 35.819]], -closed => 1, -fillcolor => "#f5ccb0", -filled => 1, -linecolor => "#f5ccb0"); -$zinc->add('curve',$top_group,[[142.674, 37.565], [136.274, 38.365, 'c'], [108.832, 15.689, 'c'], [125.874, 46.365], [147.874, 85.965, 'c'], [67.474, 85.565, 'c'], [50.674, 74.365], [33.874, 63.165, 'c'], [57.874, 92.765, 'c'], [57.874, 92.765], [76.274, 112.765, 'c'], [41.874, 95.965, 'c'], [41.874, 95.965], [7.473, 83.165, 'c'], [-16.527, 108.765, 'c'], [-19.727, 109.565], [-22.927, 110.365, 'c'], [-27.727, 113.565, 'c'], [-28.527, 107.165], [-29.327, 100.765, 'c'], [-35.786, 85.405, 'c'], [-68.527, 110.365], [-98.418, 132.929, 'c'], [-109.745, 115.293, 'c'], [-109.745, 115.293], [-115.745, 114.965], [-129.346, 88.564, 'c'], [-120.963, 144.038, 'c'], [-120.963, 144.038], [-112.163, 178.438, 'c'], [22.673, 130.365, 'c'], [22.673, 130.365], [22.673, 130.365, 'c'], [191.474, 99.965, 'c'], [202.674, 95.965], [213.874, 91.965, 'c'], [302.093, 97.783, 'c'], [302.093, 97.783], [297.075, 76.91], [232.274, 30.51, 'c'], [219.474, 58.365, 'c'], [205.874, 54.365], [192.274, 50.365, 'c'], [194.674, 59.965, 'c'], [191.474, 60.765], [188.274, 61.565, 'c'], [149.074, 36.765, 'c'], [142.674, 37.565]], -closed => 1, -fillcolor => "#f8d8c4", -filled => 1, -linecolor => "#f8d8c4"); -$zinc->add('curve',$top_group,[[143.983, 39.31], [137.583, 40.11, 'c'], [110.529, 17.223, 'c'], [127.183, 48.11], [149.183, 88.91, 'c'], [68.783, 87.31, 'c'], [51.983, 76.11], [35.183, 64.91, 'c'], [59.183, 94.51, 'c'], [59.183, 94.51], [77.583, 114.51, 'c'], [43.183, 97.71, 'c'], [43.183, 97.71], [8.783, 84.91, 'c'], [-15.217, 110.51, 'c'], [-18.417, 111.31], [-21.618, 112.11, 'c'], [-26.418, 115.31, 'c'], [-27.218, 108.91], [-28.018, 102.51, 'c'], [-34.346, 87.318, 'c'], [-67.218, 112.11], [-98.345, 135.42, 'c'], [-109.363, 118.329, 'c'], [-109.363, 118.329], [-115.764, 116.51], [-128.764, 92.51, 'c'], [-120.309, 147.093, 'c'], [-120.309, 147.093], [-111.509, 181.493, 'c'], [23.983, 132.11, 'c'], [23.983, 132.11], [23.983, 132.11, 'c'], [192.783, 101.71, 'c'], [203.983, 97.71], [215.183, 93.71, 'c'], [302.529, 99.456, 'c'], [302.529, 99.456], [297.583, 78.074], [232.783, 31.673, 'c'], [220.783, 60.11, 'c'], [207.183, 56.11], [193.583, 52.11, 'c'], [195.983, 61.71, 'c'], [192.783, 62.51], [189.583, 63.31, 'c'], [150.383, 38.51, 'c'], [143.983, 39.31]], -closed => 1, -fillcolor => "#fae5d7", -filled => 1, -linecolor => "#fae5d7"); -$zinc->add('curve',$top_group,[[145.292, 41.055], [138.892, 41.855, 'c'], [112.917, 18.411, 'c'], [128.492, 49.855], [149.692, 92.656, 'c'], [70.092, 89.056, 'c'], [53.292, 77.856], [36.492, 66.656, 'c'], [60.492, 96.256, 'c'], [60.492, 96.256], [78.892, 116.256, 'c'], [44.492, 99.456, 'c'], [44.492, 99.456], [10.092, 86.656, 'c'], [-13.908, 112.256, 'c'], [-17.108, 113.056], [-20.308, 113.856, 'c'], [-25.108, 117.056, 'c'], [-25.908, 110.656], [-26.708, 104.256, 'c'], [-32.905, 89.232, 'c'], [-65.908, 113.856], [-98.273, 137.911, 'c'], [-108.982, 121.365, 'c'], [-108.982, 121.365], [-115.782, 118.056], [-128.582, 94.856, 'c'], [-119.654, 150.147, 'c'], [-119.654, 150.147], [-110.854, 184.547, 'c'], [25.292, 133.856, 'c'], [25.292, 133.856], [25.292, 133.856, 'c'], [194.093, 103.456, 'c'], [205.293, 99.456], [216.493, 95.456, 'c'], [302.965, 101.128, 'c'], [302.965, 101.128], [298.093, 79.237], [233.292, 32.837, 'c'], [222.093, 61.856, 'c'], [208.493, 57.856], [194.893, 53.855, 'c'], [197.293, 63.456, 'c'], [194.093, 64.256], [190.892, 65.056, 'c'], [151.692, 40.255, 'c'], [145.292, 41.055]], -closed => 1, -fillcolor => "#fcf2eb", -filled => 1, -linecolor => "#fcf2eb"); -$zinc->add('curve',$top_group,[[115.8, 119.601], [-128.6, 97.6, 'c'], [-119, 153.201, 'c'], [-119, 153.201], [-110.2, 187.601, 'c'], [26.6, 135.601, 'c'], [26.6, 135.601], [26.6, 135.601, 'c'], [195.401, 105.2, 'c'], [206.601, 101.2], [217.801, 97.2, 'c'], [303.401, 102.8, 'c'], [303.401, 102.8], [298.601, 80.4], [233.801, 34, 'c'], [223.401, 63.6, 'c'], [209.801, 59.6], [196.201, 55.6, 'c'], [198.601, 65.2, 'c'], [195.401, 66], [192.201, 66.8, 'c'], [153.001, 42, 'c'], [146.601, 42.8], [140.201, 43.6, 'c'], [114.981, 19.793, 'c'], [129.801, 51.6], [152.028, 99.307, 'c'], [69.041, 89.227, 'c'], [54.6, 79.6], [37.8, 68.4, 'c'], [61.8, 98, 'c'], [61.8, 98], [80.2, 118.001, 'c'], [45.8, 101.2, 'c'], [45.8, 101.2], [11.4, 88.4, 'c'], [-12.6, 114.001, 'c'], [-15.8, 114.801], [-19, 115.601, 'c'], [-23.8, 118.801, 'c'], [-24.6, 112.401], [-25.4, 106, 'c'], [-31.465, 91.144, 'c'], [-64.6, 115.601], [-98.2, 140.401, 'c'], [-108.6, 124.401, 'c'], [-108.6, 124.401], [-115.8, 119.601]], -closed => 1, -fillcolor => "#ffffff", -filled => 1, -linecolor => "#ffffff"); -$zinc->add('curve',$top_group,[[74.2, 149.601], [-74.2, 149.601, 'c'], [-81.4, 161.201, 'c'], [-60.6, 174.401], [-60.6, 174.401, 'c'], [-59.2, 175.801, 'c'], [-77.2, 171.601], [-77.2, 171.601, 'c'], [-83.4, 169.601, 'c'], [-85, 159.201], [-85, 159.201, 'c'], [-89.8, 154.801, 'c'], [-94.6, 149.201], [-99.4, 143.601, 'c'], [-74.2, 149.601, 'c'], [-74.2, 149.601]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); -$zinc->add('curve',$top_group,[[65.8, 102], [65.8, 102, 'c'], [83.498, 128.821, 'c'], [82.9, 133.601], [81.6, 144.001, 'c'], [81.4, 153.601, 'c'], [84.6, 157.601], [87.801, 161.601, 'c'], [96.601, 194.801, 'c'], [96.601, 194.801], [96.601, 194.801, 'c'], [96.201, 196.001, 'c'], [108.601, 158.001], [108.601, 158.001, 'c'], [120.201, 142.001, 'c'], [100.201, 123.601], [100.201, 123.601, 'c'], [65, 94.8, 'c'], [65.8, 102]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); -$zinc->add('curve',$top_group,[[54.2, 176.401], [-54.2, 176.401, 'c'], [-43, 183.601, 'c'], [-57.4, 214.801], [-51, 212.401], [-51, 212.401, 'c'], [-51.8, 223.601, 'c'], [-55, 226.001], [-47.8, 222.801], [-47.8, 222.801, 'c'], [-43, 230.801, 'c'], [-47, 235.601], [-47, 235.601, 'c'], [-30.2, 243.601, 'c'], [-31, 250.001], [-31, 250.001, 'c'], [-24.6, 242.001, 'c'], [-28.6, 235.601], [-32.6, 229.201, 'c'], [-39.8, 233.201, 'c'], [-39, 214.801], [-47.8, 218.001], [-47.8, 218.001, 'c'], [-42.2, 209.201, 'c'], [-42.2, 202.801], [-50.2, 205.201], [-50.2, 205.201, 'c'], [-34.731, 178.623, 'c'], [-45.4, 177.201], [-51.4, 176.401, 'c'], [-54.2, 176.401, 'c'], [-54.2, 176.401]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); -$zinc->add('curve',$top_group,[[21.8, 193.201], [-21.8, 193.201, 'c'], [-19, 188.801, 'c'], [-21.8, 189.601], [-24.6, 190.401, 'c'], [-55.8, 205.201, 'c'], [-61.8, 214.801], [-61.8, 214.801, 'c'], [-27.4, 190.401, 'c'], [-21.8, 193.201]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); -$zinc->add('curve',$top_group,[[11.4, 201.201], [-11.4, 201.201, 'c'], [-8.6, 196.801, 'c'], [-11.4, 197.601], [-14.2, 198.401, 'c'], [-45.4, 213.201, 'c'], [-51.4, 222.801], [-51.4, 222.801, 'c'], [-17, 198.401, 'c'], [-11.4, 201.201]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); -$zinc->add('curve',$top_group,[[1.8, 186.001], [1.8, 186.001, 'c'], [4.6, 181.601, 'c'], [1.8, 182.401], [-1, 183.201, 'c'], [-32.2, 198.001, 'c'], [-38.2, 207.601], [-38.2, 207.601, 'c'], [-3.8, 183.201, 'c'], [1.8, 186.001]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); -$zinc->add('curve',$top_group,[[21.4, 229.601], [-21.4, 229.601, 'c'], [-21.4, 223.601, 'c'], [-24.2, 224.401], [-27, 225.201, 'c'], [-63, 242.801, 'c'], [-69, 252.401], [-69, 252.401, 'c'], [-27, 226.801, 'c'], [-21.4, 229.601]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); -$zinc->add('curve',$top_group,[[20.2, 218.801], [-20.2, 218.801, 'c'], [-19, 214.001, 'c'], [-21.8, 214.801], [-23.8, 214.801, 'c'], [-50.2, 226.401, 'c'], [-56.2, 236.001], [-56.2, 236.001, 'c'], [-26.6, 214.401, 'c'], [-20.2, 218.801]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); -$zinc->add('curve',$top_group,[[34.6, 266.401], [-44.6, 274.001], [-44.6, 274.001, 'c'], [-34.2, 266.401, 'c'], [-30.6, 267.601], [-30.6, 267.601, 'c'], [-37.4, 278.801, 'c'], [-38.2, 284.001], [-38.2, 284.001, 'c'], [-27.8, 271.201, 'c'], [-22.2, 271.601], [-22.2, 271.601, 'c'], [-14.6, 272.001, 'c'], [-14.6, 282.801], [-14.6, 282.801, 'c'], [-9, 272.401, 'c'], [-5.8, 272.801], [-5.8, 272.801, 'c'], [-4.6, 279.201, 'c'], [-5.8, 286.001], [-5.8, 286.001, 'c'], [-1.8, 278.401, 'c'], [2.2, 280.001], [2.2, 280.001, 'c'], [8.6, 278.001, 'c'], [7.8, 289.601], [7.8, 289.601, 'c'], [7.8, 300.001, 'c'], [7, 302.801], [7, 302.801, 'c'], [12.6, 276.401, 'c'], [15, 276.001], [15, 276.001, 'c'], [23, 274.801, 'c'], [27.8, 283.601], [27.8, 283.601, 'c'], [23.8, 276.001, 'c'], [28.6, 278.001], [28.6, 278.001, 'c'], [39.4, 279.601, 'c'], [42.6, 286.401], [42.6, 286.401, 'c'], [35.8, 274.401, 'c'], [41.4, 277.601], [41.4, 277.601, 'c'], [48.2, 277.601, 'c'], [49.4, 284.001], [49.4, 284.001, 'c'], [57.8, 305.201, 'c'], [59.8, 306.801], [59.8, 306.801, 'c'], [52.2, 285.201, 'c'], [53.8, 285.201], [53.8, 285.201, 'c'], [51.8, 273.201, 'c'], [57, 288.001], [57, 288.001, 'c'], [53.8, 274.001, 'c'], [59.4, 274.801], [65, 275.601, 'c'], [69.4, 285.601, 'c'], [77.8, 283.201], [77.8, 283.201, 'c'], [87.401, 288.801, 'c'], [89.401, 219.601], [-34.6, 266.401]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); -$zinc->add('curve',$top_group,[[29.8, 173.601], [-29.8, 173.601, 'c'], [-15, 167.601, 'c'], [25, 173.601], [25, 173.601, 'c'], [32.2, 174.001, 'c'], [39, 165.201], [45.8, 156.401, 'c'], [72.6, 149.201, 'c'], [79, 151.201], [88.601, 157.601], [89.401, 158.801], [89.401, 158.801, 'c'], [101.801, 169.201, 'c'], [102.201, 176.801], [102.601, 184.401, 'c'], [87.801, 232.401, 'c'], [78.2, 248.401], [68.6, 264.401, 'c'], [59, 276.801, 'c'], [39.8, 274.401], [39.8, 274.401, 'c'], [19, 270.401, 'c'], [-6.6, 274.401], [-6.6, 274.401, 'c'], [-35.8, 272.801, 'c'], [-38.6, 264.801], [-41.4, 256.801, 'c'], [-27.4, 241.601, 'c'], [-27.4, 241.601], [-27.4, 241.601, 'c'], [-23, 233.201, 'c'], [-24.2, 218.801], [-25.4, 204.401, 'c'], [-25, 176.401, 'c'], [-29.8, 173.601]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); -$zinc->add('curve',$top_group,[[7.8, 175.601], [0.6, 194.001, 'c'], [-29, 259.201, 'c'], [-29, 259.201], [-31, 260.801, 'c'], [-16.34, 266.846, 'c'], [-6.2, 264.401], [4.746, 261.763, 'c'], [45, 266.001, 'c'], [45, 266.001], [68.6, 250.401, 'c'], [81.4, 206.001, 'c'], [81.4, 206.001], [81.4, 206.001, 'c'], [91.801, 182.001, 'c'], [74.2, 178.801], [56.6, 175.601, 'c'], [-7.8, 175.601, 'c'], [-7.8, 175.601]], -closed => 1, -fillcolor => "#e5668c", -filled => 1, -linecolor => "#e5668c"); -$zinc->add('curve',$top_group,[[9.831, 206.497], [-6.505, 193.707, 'c'], [-4.921, 181.906, 'c'], [-7.8, 175.601], [-7.8, 175.601, 'c'], [54.6, 182.001, 'c'], [65.8, 161.201], [70.041, 153.326, 'c'], [84.801, 184.001, 'c'], [84.4, 193.601], [84.4, 193.601, 'c'], [21.4, 208.001, 'c'], [6.6, 196.801], [-9.831, 206.497]], -closed => 1, -fillcolor => "#b23259", -filled => 1, -linecolor => "#b23259"); -$zinc->add('curve',$top_group,[[5.4, 222.801], [-5.4, 222.801, 'c'], [-3.4, 230.001, 'c'], [-5.8, 234.001], [-5.8, 234.001, 'c'], [-7.4, 234.801, 'c'], [-8.6, 235.201], [-8.6, 235.201, 'c'], [-7.4, 238.801, 'c'], [-1.4, 240.401], [-1.4, 240.401, 'c'], [0.6, 244.801, 'c'], [3, 245.201], [5.4, 245.601, 'c'], [10.2, 251.201, 'c'], [14.2, 250.001], [18.2, 248.801, 'c'], [29.4, 244.801, 'c'], [29.4, 244.801], [29.4, 244.801, 'c'], [35, 241.601, 'c'], [43.8, 245.201], [43.8, 245.201, 'c'], [46.175, 244.399, 'c'], [46.6, 240.401], [47.1, 235.701, 'c'], [50.2, 232.001, 'c'], [52.2, 230.001], [54.2, 228.001, 'c'], [63.8, 215.201, 'c'], [62.6, 214.801], [61.4, 214.401, 'c'], [-5.4, 222.801, 'c'], [-5.4, 222.801]], -closed => 1, -fillcolor => "#a5264c", -filled => 1, -linecolor => "#a5264c"); -$zinc->add('curve',$top_group,[[9.8, 174.401], [-9.8, 174.401, 'c'], [-12.6, 196.801, 'c'], [-9.4, 205.201], [-6.2, 213.601, 'c'], [-7, 215.601, 'c'], [-7.8, 219.601], [-8.6, 223.601, 'c'], [-4.2, 233.601, 'c'], [1.4, 239.601], [13.4, 241.201], [13.4, 241.201, 'c'], [28.6, 237.601, 'c'], [37.8, 240.401], [37.8, 240.401, 'c'], [46.794, 241.744, 'c'], [50.2, 226.801], [50.2, 226.801, 'c'], [55, 220.401, 'c'], [62.2, 217.601], [69.4, 214.801, 'c'], [76.6, 173.201, 'c'], [72.6, 165.201], [68.6, 157.201, 'c'], [54.2, 152.801, 'c'], [38.2, 168.401], [22.2, 184.001, 'c'], [20.2, 167.201, 'c'], [-9.8, 174.401]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ff727f", -filled => 1); -$zinc->add('curve',$top_group,[[8.2, 249.201], [-8.2, 249.201, 'c'], [-9, 247.201, 'c'], [-13.4, 246.801], [-13.4, 246.801, 'c'], [-35.8, 243.201, 'c'], [-44.2, 230.801], [-44.2, 230.801, 'c'], [-51, 225.201, 'c'], [-46.6, 236.801], [-46.6, 236.801, 'c'], [-36.2, 257.201, 'c'], [-29.4, 260.001], [-29.4, 260.001, 'c'], [-13, 264.001, 'c'], [-8.2, 249.201]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); - - -$zinc->add('curve',$top_group,[[71.742, 185.229], [72.401, 177.323, 'c'], [74.354, 168.709, 'c'], [72.6, 165.201], [66.154, 152.307, 'c'], [49.181, 157.695, 'c'], [38.2, 168.401], [22.2, 184.001, 'c'], [20.2, 167.201, 'c'], [-9.8, 174.401], [-9.8, 174.401, 'c'], [-11.545, 188.364, 'c'], [-10.705, 198.376], [-10.705, 198.376, 'c'], [26.6, 186.801, 'c'], [27.4, 192.401], [27.4, 192.401, 'c'], [29, 189.201, 'c'], [38.2, 189.201], [47.4, 189.201, 'c'], [70.142, 188.029, 'c'], [71.742, 185.229]], -closed => 1, -fillcolor => "#cc3f4c", -filled => 1, -linecolor => "#cc3f4c"); -$zinc->add('curve',$top_group,[[28.6, 175.201], [28.6, 175.201, 'c'], [33.4, 180.001, 'c'], [29.8, 189.601], [29.8, 189.601, 'c'], [15.4, 205.601, 'c'], [17.4, 219.601]], -closed => 0, -linecolor => "#a51926", -linewidth => 2); -$zinc->add('curve',$top_group,[[19.4, 260.001], [-19.4, 260.001, 'c'], [-23.8, 247.201, 'c'], [-15, 254.001], [-15, 254.001, 'c'], [-10.2, 256.001, 'c'], [-11.4, 257.601], [-12.6, 259.201, 'c'], [-18.2, 263.201, 'c'], [-19.4, 260.001]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); -$zinc->add('curve',$top_group,[[14.36, 261.201], [-14.36, 261.201, 'c'], [-17.88, 250.961, 'c'], [-10.84, 256.401], [-10.84, 256.401, 'c'], [-6.419, 258.849, 'c'], [-7.96, 259.281], [-12.52, 260.561, 'c'], [-7.96, 263.121, 'c'], [-14.36, 261.201]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); -$zinc->add('curve',$top_group,[[9.56, 261.201], [-9.56, 261.201, 'c'], [-13.08, 250.961, 'c'], [-6.04, 256.401], [-6.04, 256.401, 'c'], [-1.665, 258.711, 'c'], [-3.16, 259.281], [-6.52, 260.561, 'c'], [-3.16, 263.121, 'c'], [-9.56, 261.201]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); -$zinc->add('curve',$top_group,[[2.96, 261.401], [-2.96, 261.401, 'c'], [-6.48, 251.161, 'c'], [0.56, 256.601], [0.56, 256.601, 'c'], [4.943, 258.933, 'c'], [3.441, 259.481], [0.48, 260.561, 'c'], [3.441, 263.321, 'c'], [-2.96, 261.401]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); -$zinc->add('curve',$top_group,[[3.52, 261.321], [3.52, 261.321, 'c'], [0, 251.081, 'c'], [7.041, 256.521], [7.041, 256.521, 'c'], [10.881, 258.121, 'c'], [9.921, 259.401], [8.961, 260.681, 'c'], [9.921, 263.241, 'c'], [3.52, 261.321]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); -$zinc->add('curve',$top_group,[[10.2, 262.001], [10.2, 262.001, 'c'], [5.4, 249.601, 'c'], [14.6, 256.001], [14.6, 256.001, 'c'], [19.4, 258.001, 'c'], [18.2, 259.601], [17, 261.201, 'c'], [18.2, 264.401, 'c'], [10.2, 262.001]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); -$zinc->add('curve',$top_group,[[18.2, 244.801], [-18.2, 244.801, 'c'], [-5, 242.001, 'c'], [1, 245.201], [1, 245.201, 'c'], [7, 246.401, 'c'], [8.2, 246.001], [9.4, 245.601, 'c'], [12.6, 245.201, 'c'], [12.6, 245.201]], -closed => 0, -linecolor => "#a5264c", -linewidth => 2); -$zinc->add('curve',$top_group,[[15.8, 253.601], [15.8, 253.601, 'c'], [27.8, 240.001, 'c'], [39.8, 244.401], [46.816, 246.974, 'c'], [45.8, 243.601, 'c'], [46.6, 240.801], [47.4, 238.001, 'c'], [47.6, 233.801, 'c'], [52.6, 230.801]], -closed => 0, -linecolor => "#a5264c", -linewidth => 2); -$zinc->add('curve',$top_group,[[33, 237.601], [33, 237.601, 'c'], [29, 226.801, 'c'], [26.2, 239.601], [23.4, 252.401, 'c'], [20.2, 256.001, 'c'], [18.6, 258.801], [18.6, 258.801, 'c'], [18.6, 264.001, 'c'], [27, 263.601], [27, 263.601, 'c'], [37.8, 263.201, 'c'], [38.2, 260.401], [38.6, 257.601, 'c'], [37, 246.001, 'c'], [33, 237.601]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); -$zinc->add('curve',$top_group,[[47, 244.801], [47, 244.801, 'c'], [50.6, 242.401, 'c'], [53, 243.601]], -closed => 0, -linecolor => "#a5264c", -linewidth => 2); -$zinc->add('curve',$top_group,[[53.5, 228.401], [53.5, 228.401, 'c'], [56.4, 223.501, 'c'], [61.2, 222.701]], -closed => 0, -linecolor => "#a5264c", -linewidth => 2); -$zinc->add('curve',$top_group,[[25.8, 265.201], [-25.8, 265.201, 'c'], [-7.8, 268.401, 'c'], [-3.4, 266.801], [-3.4, 266.801, 'c'], [5.4, 266.801, 'c'], [-3, 268.801], [-3, 268.801, 'c'], [-15.8, 268.801, 'c'], [-23.8, 267.601], [-23.8, 267.601, 'c'], [-35.4, 262.001, 'c'], [-25.8, 265.201]], -closed => 1, -fillcolor => "#b2b2b2", -filled => 1, -linecolor => "#b2b2b2"); -$zinc->add('curve',$top_group,[[11.8, 172.001], [-11.8, 172.001, 'c'], [5.8, 172.001, 'c'], [7.8, 172.801], [7.8, 172.801, 'c'], [15, 203.601, 'c'], [11.4, 211.201], [11.4, 211.201, 'c'], [10.2, 214.001, 'c'], [7.4, 208.401], [7.4, 208.401, 'c'], [-11, 175.601, 'c'], [-14.2, 173.601], [-17.4, 171.601, 'c'], [-13, 172.001, 'c'], [-11.8, 172.001]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); - -$zinc->add('curve',$top_group,[[-88.9, 169.301], [-88.9, 169.301, 'c'], [-80, 171.001, 'c'], [-67.4, 173.601], [-67.4, 173.601, 'c'], [-62.6, 196.001, 'c'], [-59.4, 200.801], [-56.2, 205.601, 'c'], [-59.8, 205.601, 'c'], [-63.4, 202.801], [-67, 200.001, 'c'], [-81.8, 186.001, 'c'], [-83.8, 181.601], [-85.8, 177.201, 'c'], [-88.9, 169.301, 'c'], [-88.9, 169.301]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); - -$zinc->add('curve',$top_group,[[-67.039, 173.818], [-67.039, 173.818, 'c'], [-61.239, 175.366, 'c'], [-60.23, 177.581], [-59.222, 179.795, 'c'], [-61.432, 183.092, 'c'], [-61.432, 183.092], [-61.432, 183.092, 'c'], [-62.432, 186.397, 'c'], [-63.634, 184.235], [-64.836, 182.072, 'c'], [-67.708, 174.412, 'c'], [-67.039, 173.818]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); - -$zinc->add('curve',$top_group,[[-67, 173.601], [-67, 173.601, 'c'], [-63.4, 178.801, 'c'], [-59.8, 178.801], [-56.2, 178.801, 'c'], [-55.818, 178.388, 'c'], [-53, 179.001], [-48.4, 180.001, 'c'], [-48.8, 178.001, 'c'], [-42.2, 179.201], [-39.56, 179.681, 'c'], [-37, 178.801, 'c'], [-34.2, 180.001], [-31.4, 181.201, 'c'], [-28.2, 180.401, 'c'], [-27, 178.401], [-25.8, 176.401, 'c'], [-21, 172.201, 'c'], [-21, 172.201], [-21, 172.201, 'c'], [-33.8, 174.001, 'c'], [-36.6, 174.801], [-36.6, 174.801, 'c'], [-59, 176.001, 'c'], [-67, 173.601]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-22.4, 173.801], [-22.4, 173.801, 'c'], [-28.85, 177.301, 'c'], [-29.25, 179.701], [-29.65, 182.101, 'c'], [-24, 185.801, 'c'], [-24, 185.801], [-24, 185.801, 'c'], [-21.25, 190.401, 'c'], [-20.65, 188.001], [-20.05, 185.601, 'c'], [-21.6, 174.201, 'c'], [-22.4, 173.801]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); - -$zinc->add('curve',$top_group,[[-59.885, 179.265], [-59.885, 179.265, 'c'], [-52.878, 190.453, 'c'], [-52.661, 179.242], [-52.661, 179.242, 'c'], [-52.104, 177.984, 'c'], [-53.864, 177.962], [-59.939, 177.886, 'c'], [-58.418, 173.784, 'c'], [-59.885, 179.265]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); - -$zinc->add('curve',$top_group,[[-52.707, 179.514], [-52.707, 179.514, 'c'], [-44.786, 190.701, 'c'], [-45.422, 179.421], [-45.422, 179.421, 'c'], [-45.415, 179.089, 'c'], [-47.168, 178.936], [-51.915, 178.522, 'c'], [-51.57, 174.004, 'c'], [-52.707, 179.514]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); - -$zinc->add('curve',$top_group,[[-45.494, 179.522], [-45.494, 179.522, 'c'], [-37.534, 190.15, 'c'], [-38.203, 180.484], [-38.203, 180.484, 'c'], [-38.084, 179.251, 'c'], [-39.738, 178.95], [-43.63, 178.244, 'c'], [-43.841, 174.995, 'c'], [-45.494, 179.522]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); - -$zinc->add('curve',$top_group,[[-38.618, 179.602], [-38.618, 179.602, 'c'], [-30.718, 191.163, 'c'], [-30.37, 181.382], [-30.37, 181.382, 'c'], [-28.726, 180.004, 'c'], [-30.472, 179.782], [-36.29, 179.042, 'c'], [-35.492, 174.588, 'c'], [-38.618, 179.602]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffcc", -filled => 1, -linewidth => 0.5); - -$zinc->add('curve',$top_group,[[-74.792, 183.132], [-82.45, 181.601], [-85.05, 176.601, 'c'], [-87.15, 170.451, 'c'], [-87.15, 170.451], [-87.15, 170.451, 'c'], [-80.8, 171.451, 'c'], [-68.3, 174.251], [-68.3, 174.251, 'c'], [-67.424, 177.569, 'c'], [-65.952, 183.364], [-74.792, 183.132]], -closed => 1, -fillcolor => "#e5e5b2", -filled => 1, -linecolor => "#e5e5b2"); - -$zinc->add('curve',$top_group,[[-9.724, 178.47], [-11.39, 175.964, 'c'], [-12.707, 174.206, 'c'], [-13.357, 173.8], [-16.37, 171.917, 'c'], [-12.227, 172.294, 'c'], [-11.098, 172.294], [-11.098, 172.294, 'c'], [5.473, 172.294, 'c'], [7.356, 173.047], [7.356, 173.047, 'c'], [7.88, 175.289, 'c'], [8.564, 178.68], [8.564, 178.68, 'c'], [-1.524, 176.67, 'c'], [-9.724, 178.47]], -closed => 1, -fillcolor => "#e5e5b2", -filled => 1, -linecolor => "#e5e5b2"); - -$zinc->add('curve',$top_group,[[43.88, 40.321], [71.601, 44.281, 'c'], [97.121, 8.641, 'c'], [98.881, -1.04], [100.641, -10.72, 'c'], [90.521, -22.6, 'c'], [90.521, -22.6], [91.841, -25.68, 'c'], [87.001, -39.76, 'c'], [81.721, -49], [76.441, -58.24, 'c'], [60.54, -57.266, 'c'], [43, -58.24], [27.16, -59.12, 'c'], [8.68, -35.8, 'c'], [7.36, -34.04], [6.04, -32.28, 'c'], [12.2, 6.001, 'c'], [13.52, 11.721], [14.84, 17.441, 'c'], [12.2, 43.841, 'c'], [12.2, 43.841], [46.44, 34.741, 'c'], [16.16, 36.361, 'c'], [43.88, 40.321]], -closed => 1, -fillcolor => "#cc7226", -filled => 1, -linecolor => "#cc7226"); - -$zinc->add('curve',$top_group,[[8.088, -33.392], [6.792, -31.664, 'c'], [12.84, 5.921, 'c'], [14.136, 11.537], [15.432, 17.153, 'c'], [12.84, 43.073, 'c'], [12.84, 43.073], [45.512, 34.193, 'c'], [16.728, 35.729, 'c'], [43.944, 39.617], [71.161, 43.505, 'c'], [96.217, 8.513, 'c'], [97.945, -0.992], [99.673, -10.496, 'c'], [89.737, -22.16, 'c'], [89.737, -22.16], [91.033, -25.184, 'c'], [86.281, -39.008, 'c'], [81.097, -48.08], [75.913, -57.152, 'c'], [60.302, -56.195, 'c'], [43.08, -57.152], [27.528, -58.016, 'c'], [9.384, -35.12, 'c'], [8.088, -33.392]], -closed => 1, -fillcolor => "#ea8e51", -filled => 1, -linecolor => "#ea8e51"); - -$zinc->add('curve',$top_group,[[8.816, -32.744], [7.544, -31.048, 'c'], [13.48, 5.841, 'c'], [14.752, 11.353], [16.024, 16.865, 'c'], [13.48, 42.305, 'c'], [13.48, 42.305], [44.884, 33.145, 'c'], [17.296, 35.097, 'c'], [44.008, 38.913], [70.721, 42.729, 'c'], [95.313, 8.385, 'c'], [97.009, -0.944], [98.705, -10.272, 'c'], [88.953, -21.72, 'c'], [88.953, -21.72], [90.225, -24.688, 'c'], [85.561, -38.256, 'c'], [80.473, -47.16], [75.385, -56.064, 'c'], [60.063, -55.125, 'c'], [43.16, -56.064], [27.896, -56.912, 'c'], [10.088, -34.44, 'c'], [8.816, -32.744]], -closed => 1, -fillcolor => "#efaa7c", -filled => 1, -linecolor => "#efaa7c"); - -$zinc->add('curve',$top_group,[[9.544, -32.096], [8.296, -30.432, 'c'], [14.12, 5.761, 'c'], [15.368, 11.169], [16.616, 16.577, 'c'], [14.12, 41.537, 'c'], [14.12, 41.537], [43.556, 32.497, 'c'], [17.864, 34.465, 'c'], [44.072, 38.209], [70.281, 41.953, 'c'], [94.409, 8.257, 'c'], [96.073, -0.895], [97.737, -10.048, 'c'], [88.169, -21.28, 'c'], [88.169, -21.28], [89.417, -24.192, 'c'], [84.841, -37.504, 'c'], [79.849, -46.24], [74.857, -54.976, 'c'], [59.824, -54.055, 'c'], [43.24, -54.976], [28.264, -55.808, 'c'], [10.792, -33.76, 'c'], [9.544, -32.096]], -closed => 1, -fillcolor => "#f4c6a8", -filled => 1, -linecolor => "#f4c6a8"); - -$zinc->add('curve',$top_group,[[10.272, -31.448], [9.048, -29.816, 'c'], [14.76, 5.681, 'c'], [15.984, 10.985], [17.208, 16.289, 'c'], [14.76, 40.769, 'c'], [14.76, 40.769], [42.628, 31.849, 'c'], [18.432, 33.833, 'c'], [44.136, 37.505], [69.841, 41.177, 'c'], [93.505, 8.129, 'c'], [95.137, -0.848], [96.769, -9.824, 'c'], [87.385, -20.84, 'c'], [87.385, -20.84], [88.609, -23.696, 'c'], [84.121, -36.752, 'c'], [79.225, -45.32], [74.329, -53.888, 'c'], [59.585, -52.985, 'c'], [43.32, -53.888], [28.632, -54.704, 'c'], [11.496, -33.08, 'c'], [10.272, -31.448]], -closed => 1, -fillcolor => "#f9e2d3", -filled => 1, -linecolor => "#f9e2d3"); - -$zinc->add('curve',$top_group,[[44.2, 36.8], [69.4, 40.4, 'c'], [92.601, 8, 'c'], [94.201, -0.8], [95.801, -9.6, 'c'], [86.601, -20.4, 'c'], [86.601, -20.4], [87.801, -23.2, 'c'], [83.4, -36, 'c'], [78.6, -44.4], [73.8, -52.8, 'c'], [59.346, -51.914, 'c'], [43.4, -52.8], [29, -53.6, 'c'], [12.2, -32.4, 'c'], [11, -30.8], [9.8, -29.2, 'c'], [15.4, 5.6, 'c'], [16.6, 10.8], [17.8, 16, 'c'], [15.4, 40, 'c'], [15.4, 40], [40.9, 31.4, 'c'], [19, 33.2, 'c'], [44.2, 36.8]], -closed => 1, -fillcolor => "#ffffff", -filled => 1, -linecolor => "#ffffff"); - -$zinc->add('curve',$top_group,[[90.601, 2.8], [90.601, 2.8, 'c'], [62.8, 10.4, 'c'], [51.2, 8.8], [51.2, 8.8, 'c'], [35.4, 2.2, 'c'], [26.6, 24], [26.6, 24, 'c'], [23, 31.2, 'c'], [21, 33.2], [19, 35.2, 'c'], [90.601, 2.8, 'c'], [90.601, 2.8]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[94.401, 0.6], [94.401, 0.6, 'c'], [65.4, 12.8, 'c'], [55.4, 12.4], [55.4, 12.4, 'c'], [39, 7.8, 'c'], [30.6, 22.4], [30.6, 22.4, 'c'], [22.2, 31.6, 'c'], [19, 33.2], [19, 33.2, 'c'], [18.6, 34.8, 'c'], [25, 30.8], [35.4, 36], [35.4, 36, 'c'], [50.2, 45.6, 'c'], [59.8, 29.6], [59.8, 29.6, 'c'], [63.8, 18.4, 'c'], [63.8, 16.4], [63.8, 14.4, 'c'], [85, 8.8, 'c'], [86.601, 8.4], [88.201, 8, 'c'], [94.801, 3.8, 'c'], [94.401, 0.6]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[47, 36.514], [40.128, 36.514, 'c'], [31.755, 32.649, 'c'], [31.755, 26.4], [31.755, 20.152, 'c'], [40.128, 13.887, 'c'], [47, 13.887], [53.874, 13.887, 'c'], [59.446, 18.952, 'c'], [59.446, 25.2], [59.446, 31.449, 'c'], [53.874, 36.514, 'c'], [47, 36.514]], -closed => 1, -fillcolor => "#99cc32", -filled => 1, -linecolor => "#99cc32"); - -$zinc->add('curve',$top_group,[[43.377, 19.83], [38.531, 20.552, 'c'], [33.442, 22.055, 'c'], [33.514, 21.839], [35.054, 17.22, 'c'], [41.415, 13.887, 'c'], [47, 13.887], [51.296, 13.887, 'c'], [55.084, 15.865, 'c'], [57.32, 18.875], [57.32, 18.875, 'c'], [52.004, 18.545, 'c'], [43.377, 19.83]], -closed => 1, -fillcolor => "#659900", -filled => 1, -linecolor => "#659900"); - -$zinc->add('curve',$top_group,[[55.4, 19.6], [55.4, 19.6, 'c'], [51, 16.4, 'c'], [51, 18.6], [51, 18.6, 'c'], [54.6, 23, 'c'], [55.4, 19.6]], -closed => 1, -fillcolor => "#ffffff", -filled => 1, -linecolor => "#ffffff"); - -$zinc->add('curve',$top_group,[[45.4, 27.726], [42.901, 27.726, 'c'], [40.875, 25.7, 'c'], [40.875, 23.2], [40.875, 20.701, 'c'], [42.901, 18.675, 'c'], [45.4, 18.675], [47.9, 18.675, 'c'], [49.926, 20.701, 'c'], [49.926, 23.2], [49.926, 25.7, 'c'], [47.9, 27.726, 'c'], [45.4, 27.726]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-58.6, 14.4], [-58.6, 14.4, 'c'], [-61.8, -6.8, 'c'], [-59.4, -11.2], [-59.4, -11.2, 'c'], [-48.6, -21.2, 'c'], [-49, -24.8], [-49, -24.8, 'c'], [-49.4, -42.8, 'c'], [-50.6, -43.6], [-51.8, -44.4, 'c'], [-59.4, -50.4, 'c'], [-65.4, -44], [-65.4, -44, 'c'], [-75.8, -26, 'c'], [-75, -19.6], [-75, -17.6], [-75, -17.6, 'c'], [-82.6, -18, 'c'], [-84.2, -16], [-84.2, -16, 'c'], [-85.4, -10.8, 'c'], [-86.6, -10.4], [-86.6, -10.4, 'c'], [-89.4, -8, 'c'], [-87.4, -5.2], [-87.4, -5.2, 'c'], [-89.4, -2.8, 'c'], [-89, 1.2], [-81.4, 5.2], [-81.4, 5.2, 'c'], [-79.4, 19.6, 'c'], [-68.6, 24.8], [-63.764, 27.129, 'c'], [-60.6, 20.4, 'c'], [-58.6, 14.4]], -closed => 1, -fillcolor => "#cc7226", -filled => 1, -linecolor => "#cc7226"); - -$zinc->add('curve',$top_group,[[-59.6, 12.56], [-59.6, 12.56, 'c'], [-62.48, -6.52, 'c'], [-60.32, -10.48], [-60.32, -10.48, 'c'], [-50.6, -19.48, 'c'], [-50.96, -22.72], [-50.96, -22.72, 'c'], [-51.32, -38.92, 'c'], [-52.4, -39.64], [-53.48, -40.36, 'c'], [-60.32, -45.76, 'c'], [-65.72, -40], [-65.72, -40, 'c'], [-75.08, -23.8, 'c'], [-74.36, -18.04], [-74.36, -16.24], [-74.36, -16.24, 'c'], [-81.2, -16.6, 'c'], [-82.64, -14.8], [-82.64, -14.8, 'c'], [-83.72, -10.12, 'c'], [-84.8, -9.76], [-84.8, -9.76, 'c'], [-87.32, -7.6, 'c'], [-85.52, -5.08], [-85.52, -5.08, 'c'], [-87.32, -2.92, 'c'], [-86.96, 0.68], [-80.12, 4.28], [-80.12, 4.28, 'c'], [-78.32, 17.24, 'c'], [-68.6, 21.92], [-64.248, 24.015, 'c'], [-61.4, 17.96, 'c'], [-59.6, 12.56]], -closed => 1, -fillcolor => "#ffffff", -filled => 1, -linecolor => "#ffffff"); - -$zinc->add('curve',$top_group,[[-51.05, -42.61], [-52.14, -43.47, 'c'], [-59.63, -49.24, 'c'], [-65.48, -43], [-65.48, -43, 'c'], [-75.62, -25.45, 'c'], [-74.84, -19.21], [-74.84, -17.26], [-74.84, -17.26, 'c'], [-82.25, -17.65, 'c'], [-83.81, -15.7], [-83.81, -15.7, 'c'], [-84.98, -10.63, 'c'], [-86.15, -10.24], [-86.15, -10.24, 'c'], [-88.88, -7.9, 'c'], [-86.93, -5.17], [-86.93, -5.17, 'c'], [-88.88, -2.83, 'c'], [-88.49, 1.07], [-81.08, 4.97], [-81.08, 4.97, 'c'], [-79.13, 19.01, 'c'], [-68.6, 24.08], [-63.886, 26.35, 'c'], [-60.8, 19.79, 'c'], [-58.85, 13.94], [-58.85, 13.94, 'c'], [-61.97, -6.73, 'c'], [-59.63, -11.02], [-59.63, -11.02, 'c'], [-49.1, -20.77, 'c'], [-49.49, -24.28], [-49.49, -24.28, 'c'], [-49.88, -41.83, 'c'], [-51.05, -42.61]], -closed => 1, -fillcolor => "#eb955c", -filled => 1, -linecolor => "#eb955c"); - -$zinc->add('curve',$top_group,[[-51.5, -41.62], [-52.48, -42.54, 'c'], [-59.86, -48.08, 'c'], [-65.56, -42], [-65.56, -42, 'c'], [-75.44, -24.9, 'c'], [-74.68, -18.82], [-74.68, -16.92], [-74.68, -16.92, 'c'], [-81.9, -17.3, 'c'], [-83.42, -15.4], [-83.42, -15.4, 'c'], [-84.56, -10.46, 'c'], [-85.7, -10.08], [-85.7, -10.08, 'c'], [-88.36, -7.8, 'c'], [-86.46, -5.14], [-86.46, -5.14, 'c'], [-88.36, -2.86, 'c'], [-87.98, 0.94], [-80.76, 4.74], [-80.76, 4.74, 'c'], [-78.86, 18.42, 'c'], [-68.6, 23.36], [-64.006, 25.572, 'c'], [-61, 19.18, 'c'], [-59.1, 13.48], [-59.1, 13.48, 'c'], [-62.14, -6.66, 'c'], [-59.86, -10.84], [-59.86, -10.84, 'c'], [-49.6, -20.34, 'c'], [-49.98, -23.76], [-49.98, -23.76, 'c'], [-50.36, -40.86, 'c'], [-51.5, -41.62]], -closed => 1, -fillcolor => "#f2b892", -filled => 1, -linecolor => "#f2b892"); - -$zinc->add('curve',$top_group,[[-51.95, -40.63], [-52.82, -41.61, 'c'], [-60.09, -46.92, 'c'], [-65.64, -41], [-65.64, -41, 'c'], [-75.26, -24.35, 'c'], [-74.52, -18.43], [-74.52, -16.58], [-74.52, -16.58, 'c'], [-81.55, -16.95, 'c'], [-83.03, -15.1], [-83.03, -15.1, 'c'], [-84.14, -10.29, 'c'], [-85.25, -9.92], [-85.25, -9.92, 'c'], [-87.84, -7.7, 'c'], [-85.99, -5.11], [-85.99, -5.11, 'c'], [-87.84, -2.89, 'c'], [-87.47, 0.81], [-80.44, 4.51], [-80.44, 4.51, 'c'], [-78.59, 17.83, 'c'], [-68.6, 22.64], [-64.127, 24.794, 'c'], [-61.2, 18.57, 'c'], [-59.35, 13.02], [-59.35, 13.02, 'c'], [-62.31, -6.59, 'c'], [-60.09, -10.66], [-60.09, -10.66, 'c'], [-50.1, -19.91, 'c'], [-50.47, -23.24], [-50.47, -23.24, 'c'], [-50.84, -39.89, 'c'], [-51.95, -40.63]], -closed => 1, -fillcolor => "#f8dcc8", -filled => 1, -linecolor => "#f8dcc8"); - -$zinc->add('curve',$top_group,[[-59.6, 12.46], [-59.6, 12.46, 'c'], [-62.48, -6.52, 'c'], [-60.32, -10.48], [-60.32, -10.48, 'c'], [-50.6, -19.48, 'c'], [-50.96, -22.72], [-50.96, -22.72, 'c'], [-51.32, -38.92, 'c'], [-52.4, -39.64], [-53.16, -40.68, 'c'], [-60.32, -45.76, 'c'], [-65.72, -40], [-65.72, -40, 'c'], [-75.08, -23.8, 'c'], [-74.36, -18.04], [-74.36, -16.24], [-74.36, -16.24, 'c'], [-81.2, -16.6, 'c'], [-82.64, -14.8], [-82.64, -14.8, 'c'], [-83.72, -10.12, 'c'], [-84.8, -9.76], [-84.8, -9.76, 'c'], [-87.32, -7.6, 'c'], [-85.52, -5.08], [-85.52, -5.08, 'c'], [-87.32, -2.92, 'c'], [-86.96, 0.68], [-80.12, 4.28], [-80.12, 4.28, 'c'], [-78.32, 17.24, 'c'], [-68.6, 21.92], [-64.248, 24.015, 'c'], [-61.4, 17.86, 'c'], [-59.6, 12.46]], -closed => 1, -fillcolor => "#ffffff", -filled => 1, -linecolor => "#ffffff"); - -$zinc->add('curve',$top_group,[[-62.7, 6.2], [-62.7, 6.2, 'c'], [-84.3, -4, 'c'], [-85.2, -4.8], [-85.2, -4.8, 'c'], [-76.1, 3.4, 'c'], [-75.3, 3.4], [-74.5, 3.4, 'c'], [-62.7, 6.2, 'c'], [-62.7, 6.2]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-79.8, 0], [-79.8, 0, 'c'], [-61.4, 3.6, 'c'], [-61.4, 8], [-61.4, 10.912, 'c'], [-61.643, 24.331, 'c'], [-67, 22.8], [-75.4, 20.4, 'c'], [-71.8, 6, 'c'], [-79.8, 0]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-71.4, 3.8], [-71.4, 3.8, 'c'], [-62.422, 5.274, 'c'], [-61.4, 8], [-60.8, 9.6, 'c'], [-60.137, 17.908, 'c'], [-65.6, 19], [-70.152, 19.911, 'c'], [-72.382, 9.69, 'c'], [-71.4, 3.8]], -closed => 1, -fillcolor => "#99cc32", -filled => 1, -linecolor => "#99cc32"); - -$zinc->add('curve',$top_group,[[14.595, 46.349], [14.098, 44.607, 'c'], [15.409, 44.738, 'c'], [17.2, 44.2], [19.2, 43.6, 'c'], [31.4, 39.8, 'c'], [32.2, 37.2], [33, 34.6, 'c'], [46.2, 39, 'c'], [46.2, 39], [48, 39.8, 'c'], [52.4, 42.4, 'c'], [52.4, 42.4], [57.2, 43.6, 'c'], [63.8, 44, 'c'], [63.8, 44], [66.2, 45, 'c'], [69.6, 47.8, 'c'], [69.6, 47.8], [84.2, 58, 'c'], [96.601, 50.8, 'c'], [96.601, 50.8], [116.601, 44.2, 'c'], [110.601, 27, 'c'], [110.601, 27], [107.601, 18, 'c'], [110.801, 14.6, 'c'], [110.801, 14.6], [111.001, 10.8, 'c'], [118.201, 17.2, 'c'], [118.201, 17.2], [120.801, 21.4, 'c'], [121.601, 26.4, 'c'], [121.601, 26.4], [129.601, 37.6, 'c'], [126.201, 19.8, 'c'], [126.201, 19.8], [126.401, 18.8, 'c'], [123.601, 15.2, 'c'], [123.601, 14], [123.601, 12.8, 'c'], [121.801, 9.4, 'c'], [121.801, 9.4], [118.801, 6, 'c'], [121.201, -1, 'c'], [121.201, -1], [123.001, -14.8, 'c'], [120.801, -13, 'c'], [120.801, -13], [119.601, -14.8, 'c'], [110.401, -4.8, 'c'], [110.401, -4.8], [108.201, -1.4, 'c'], [102.201, 0.2, 'c'], [102.201, 0.2], [99.401, 2, 'c'], [96.001, 0.6, 'c'], [96.001, 0.6], [93.401, 0.2, 'c'], [87.801, 7.2, 'c'], [87.801, 7.2], [90.601, 7, 'c'], [93.001, 11.4, 'c'], [95.401, 11.6], [97.801, 11.8, 'c'], [99.601, 9.2, 'c'], [101.201, 8.6], [102.801, 8, 'c'], [105.601, 13.8, 'c'], [105.601, 13.8], [106.001, 16.4, 'c'], [100.401, 21.2, 'c'], [100.401, 21.2], [100.001, 25.8, 'c'], [98.401, 24.2, 'c'], [98.401, 24.2], [95.401, 23.6, 'c'], [94.201, 27.4, 'c'], [93.201, 32], [92.201, 36.6, 'c'], [88.001, 37, 'c'], [88.001, 37], [86.401, 44.4, 'c'], [85.2, 41.4, 'c'], [85.2, 41.4], [85, 35.8, 'c'], [79, 41.6, 'c'], [79, 41.6], [77.8, 43.6, 'c'], [73.2, 41.4, 'c'], [73.2, 41.4], [66.4, 39.4, 'c'], [68.8, 37.4, 'c'], [68.8, 37.4], [70.6, 35.2, 'c'], [81.8, 37.4, 'c'], [81.8, 37.4], [84, 35.8, 'c'], [76, 31.8, 'c'], [76, 31.8], [75.4, 30, 'c'], [76.4, 25.6, 'c'], [76.4, 25.6], [77.6, 22.4, 'c'], [84.4, 16.8, 'c'], [84.4, 16.8], [93.801, 15.6, 'c'], [91.001, 14, 'c'], [91.001, 14], [84.801, 8.8, 'c'], [79, 16.4, 'c'], [79, 16.4], [76.8, 22.6, 'c'], [59.4, 37.6, 'c'], [59.4, 37.6], [54.6, 41, 'c'], [57.2, 34.2, 'c'], [53.2, 37.6], [49.2, 41, 'c'], [28.6, 32, 'c'], [28.6, 32], [17.038, 30.807, 'c'], [14.306, 46.549, 'c'], [10.777, 43.429], [10.777, 43.429, 'c'], [16.195, 51.949, 'c'], [14.595, 46.349]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[209.401, -120], [209.401, -120, 'c'], [183.801, -112, 'c'], [181.001, -93.2], [181.001, -93.2, 'c'], [178.601, -70.4, 'c'], [199.001, -52.8], [199.001, -52.8, 'c'], [199.401, -46.4, 'c'], [201.401, -43.2], [201.401, -43.2, 'c'], [199.801, -38.4, 'c'], [218.601, -46], [245.801, -54.4], [245.801, -54.4, 'c'], [252.201, -56.8, 'c'], [257.401, -65.6], [262.601, -74.4, 'c'], [277.801, -93.2, 'c'], [274.201, -118.4], [274.201, -118.4, 'c'], [275.401, -129.6, 'c'], [269.401, -130], [269.401, -130, 'c'], [261.001, -131.6, 'c'], [253.801, -124], [253.801, -124, 'c'], [247.001, -120.8, 'c'], [244.601, -121.2], [209.401, -120]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[264.022, -120.99], [264.022, -120.99, 'c'], [266.122, -129.92, 'c'], [261.282, -125.08], [261.282, -125.08, 'c'], [254.242, -119.36, 'c'], [246.761, -119.36], [246.761, -119.36, 'c'], [232.241, -117.16, 'c'], [227.841, -103.96], [227.841, -103.96, 'c'], [223.881, -77.12, 'c'], [231.801, -71.4], [231.801, -71.4, 'c'], [236.641, -63.92, 'c'], [243.681, -70.52], [250.722, -77.12, 'c'], [266.222, -107.35, 'c'], [264.022, -120.99]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[263.648, -120.632], [263.648, -120.632, 'c'], [265.738, -129.376, 'c'], [260.986, -124.624], [260.986, -124.624, 'c'], [254.074, -119.008, 'c'], [246.729, -119.008], [246.729, -119.008, 'c'], [232.473, -116.848, 'c'], [228.153, -103.888], [228.153, -103.888, 'c'], [224.265, -77.536, 'c'], [232.041, -71.92], [232.041, -71.92, 'c'], [236.793, -64.576, 'c'], [243.705, -71.056], [250.618, -77.536, 'c'], [265.808, -107.24, 'c'], [263.648, -120.632]], -closed => 1, -fillcolor => "#323232", -filled => 1, -linecolor => "#323232"); - -$zinc->add('curve',$top_group,[[263.274, -120.274], [263.274, -120.274, 'c'], [265.354, -128.832, 'c'], [260.69, -124.168], [260.69, -124.168, 'c'], [253.906, -118.656, 'c'], [246.697, -118.656], [246.697, -118.656, 'c'], [232.705, -116.536, 'c'], [228.465, -103.816], [228.465, -103.816, 'c'], [224.649, -77.952, 'c'], [232.281, -72.44], [232.281, -72.44, 'c'], [236.945, -65.232, 'c'], [243.729, -71.592], [250.514, -77.952, 'c'], [265.394, -107.13, 'c'], [263.274, -120.274]], -closed => 1, -fillcolor => "#666666", -filled => 1, -linecolor => "#666666"); - -$zinc->add('curve',$top_group,[[262.9, -119.916], [262.9, -119.916, 'c'], [264.97, -128.288, 'c'], [260.394, -123.712], [260.394, -123.712, 'c'], [253.738, -118.304, 'c'], [246.665, -118.304], [246.665, -118.304, 'c'], [232.937, -116.224, 'c'], [228.777, -103.744], [228.777, -103.744, 'c'], [225.033, -78.368, 'c'], [232.521, -72.96], [232.521, -72.96, 'c'], [237.097, -65.888, 'c'], [243.753, -72.128], [250.41, -78.368, 'c'], [264.98, -107.02, 'c'], [262.9, -119.916]], -closed => 1, -fillcolor => "#999999", -filled => 1, -linecolor => "#999999"); - -$zinc->add('curve',$top_group,[[262.526, -119.558], [262.526, -119.558, 'c'], [264.586, -127.744, 'c'], [260.098, -123.256], [260.098, -123.256, 'c'], [253.569, -117.952, 'c'], [246.633, -117.952], [246.633, -117.952, 'c'], [233.169, -115.912, 'c'], [229.089, -103.672], [229.089, -103.672, 'c'], [225.417, -78.784, 'c'], [232.761, -73.48], [232.761, -73.48, 'c'], [237.249, -66.544, 'c'], [243.777, -72.664], [250.305, -78.784, 'c'], [264.566, -106.91, 'c'], [262.526, -119.558]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[262.151, -119.2], [262.151, -119.2, 'c'], [264.201, -127.2, 'c'], [259.801, -122.8], [259.801, -122.8, 'c'], [253.401, -117.6, 'c'], [246.601, -117.6], [246.601, -117.6, 'c'], [233.401, -115.6, 'c'], [229.401, -103.6], [229.401, -103.6, 'c'], [225.801, -79.2, 'c'], [233.001, -74], [233.001, -74, 'c'], [237.401, -67.2, 'c'], [243.801, -73.2], [250.201, -79.2, 'c'], [264.151, -106.8, 'c'], [262.151, -119.2]], -closed => 1, -fillcolor => "#ffffff", -filled => 1, -linecolor => "#ffffff"); - -$zinc->add('curve',$top_group,[[50.6, 84], [50.6, 84, 'c'], [30.2, 64.8, 'c'], [22.2, 64], [22.2, 64, 'c'], [-12.2, 60, 'c'], [-27, 78], [-27, 78, 'c'], [-9.4, 57.6, 'c'], [18.2, 63.2], [18.2, 63.2, 'c'], [-3.4, 58.8, 'c'], [-15.8, 62], [-15.8, 62, 'c'], [-32.6, 62, 'c'], [-42.2, 76], [-45, 80.8], [-45, 80.8, 'c'], [-41, 66, 'c'], [-22.6, 60], [-22.6, 60, 'c'], [0.2, 55.2, 'c'], [11, 60], [11, 60, 'c'], [-10.6, 53.2, 'c'], [-20.6, 55.2], [-20.6, 55.2, 'c'], [-51, 52.8, 'c'], [-63.8, 79.2], [-63.8, 79.2, 'c'], [-59.8, 64.8, 'c'], [-45, 57.6], [-45, 57.6, 'c'], [-31.4, 48.8, 'c'], [-11, 51.6], [-11, 51.6, 'c'], [3.4, 54.8, 'c'], [8.6, 57.2], [13.8, 59.6, 'c'], [12.6, 56.8, 'c'], [4.2, 52], [4.2, 52, 'c'], [-1.4, 42, 'c'], [-15.4, 42.4], [-15.4, 42.4, 'c'], [-58.2, 46, 'c'], [-68.6, 58], [-68.6, 58, 'c'], [-55, 46.8, 'c'], [-44.6, 44], [-44.6, 44, 'c'], [-22.2, 36, 'c'], [-13.8, 36.8], [-13.8, 36.8, 'c'], [11, 37.8, 'c'], [18.6, 33.8], [18.6, 33.8, 'c'], [7.4, 38.8, 'c'], [10.6, 42], [13.8, 45.2, 'c'], [20.6, 52.8, 'c'], [20.6, 54], [20.6, 55.2, 'c'], [44.8, 77.3, 'c'], [48.4, 81.7], [50.6, 84]], -closed => 1, -fillcolor => "#992600", -filled => 1, -linecolor => "#992600"); - -$zinc->add('curve',$top_group,[[189, 278], [189, 278, 'c'], [173.5, 241.5, 'c'], [161, 232], [161, 232, 'c'], [187, 248, 'c'], [190.5, 266], [190.5, 266, 'c'], [190.5, 276, 'c'], [189, 278]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[236, 285.5], [236, 285.5, 'c'], [209.5, 230.5, 'c'], [191, 206.5], [191, 206.5, 'c'], [234.5, 244, 'c'], [239.5, 270.5], [240, 276], [237, 273.5], [237, 273.5, 'c'], [236.5, 282.5, 'c'], [236, 285.5]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[292.5, 237], [292.5, 237, 'c'], [230, 177.5, 'c'], [228.5, 175], [228.5, 175, 'c'], [289, 241, 'c'], [292, 248.5], [292, 248.5, 'c'], [290, 239.5, 'c'], [292.5, 237]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[104, 280.5], [104, 280.5, 'c'], [123.5, 228.5, 'c'], [142.5, 251], [142.5, 251, 'c'], [157.5, 261, 'c'], [157, 264], [157, 264, 'c'], [153, 257.5, 'c'], [135, 258], [135, 258, 'c'], [116, 255, 'c'], [104, 280.5]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[294.5, 153], [294.5, 153, 'c'], [249.5, 124.5, 'c'], [242, 123], [230.193, 120.639, 'c'], [291.5, 152, 'c'], [296.5, 162.5], [296.5, 162.5, 'c'], [298.5, 160, 'c'], [294.5, 153]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[143.801, 259.601], [143.801, 259.601, 'c'], [164.201, 257.601, 'c'], [171.001, 250.801], [175.401, 254.401], [193.001, 216.001], [196.601, 221.201], [196.601, 221.201, 'c'], [211.001, 206.401, 'c'], [210.201, 198.401], [209.401, 190.401, 'c'], [223.001, 204.401, 'c'], [223.001, 204.401], [223.001, 204.401, 'c'], [222.201, 192.801, 'c'], [229.401, 199.601], [229.401, 199.601, 'c'], [227.001, 184.001, 'c'], [235.401, 192.001], [235.401, 192.001, 'c'], [224.864, 161.844, 'c'], [247.401, 187.601], [253.001, 194.001, 'c'], [248.601, 187.201, 'c'], [248.601, 187.201], [248.601, 187.201, 'c'], [222.601, 139.201, 'c'], [244.201, 153.601], [244.201, 153.601, 'c'], [246.201, 130.801, 'c'], [245.001, 126.401], [243.801, 122.001, 'c'], [241.801, 99.6, 'c'], [237.001, 94.4], [232.201, 89.2, 'c'], [237.401, 87.6, 'c'], [243.001, 92.8], [243.001, 92.8, 'c'], [231.801, 68.8, 'c'], [245.001, 80.8], [245.001, 80.8, 'c'], [241.401, 65.6, 'c'], [237.001, 62.8], [237.001, 62.8, 'c'], [231.401, 45.6, 'c'], [246.601, 56.4], [246.601, 56.4, 'c'], [242.201, 44, 'c'], [239.001, 40.8], [239.001, 40.8, 'c'], [227.401, 13.2, 'c'], [234.601, 18], [239.001, 21.6], [239.001, 21.6, 'c'], [232.201, 7.6, 'c'], [238.601, 12], [245.001, 16.4, 'c'], [245.001, 16, 'c'], [245.001, 16], [245.001, 16, 'c'], [223.801, -17.2, 'c'], [244.201, 0.4], [244.201, 0.4, 'c'], [236.042, -13.518, 'c'], [232.601, -20.4], [232.601, -20.4, 'c'], [213.801, -40.8, 'c'], [228.201, -34.4], [233.001, -32.8], [233.001, -32.8, 'c'], [224.201, -42.8, 'c'], [216.201, -44.4], [208.201, -46, 'c'], [218.601, -52.4, 'c'], [225.001, -50.4], [231.401, -48.4, 'c'], [247.001, -40.8, 'c'], [247.001, -40.8], [247.001, -40.8, 'c'], [259.801, -22, 'c'], [263.801, -21.6], [263.801, -21.6, 'c'], [243.801, -29.2, 'c'], [249.801, -21.2], [249.801, -21.2, 'c'], [264.201, -7.2, 'c'], [257.001, -7.6], [257.001, -7.6, 'c'], [251.001, -0.4, 'c'], [255.801, 8.4], [255.801, 8.4, 'c'], [237.342, -9.991, 'c'], [252.201, 15.6], [259.001, 32], [259.001, 32, 'c'], [234.601, 7.2, 'c'], [245.801, 29.2], [245.801, 29.2, 'c'], [263.001, 52.8, 'c'], [265.001, 53.2], [267.001, 53.6, 'c'], [271.401, 62.4, 'c'], [271.401, 62.4], [267.001, 60.4], [272.201, 69.2], [272.201, 69.2, 'c'], [261.001, 57.2, 'c'], [267.001, 70.4], [272.601, 84.8], [272.601, 84.8, 'c'], [252.201, 62.8, 'c'], [265.801, 92.4], [265.801, 92.4, 'c'], [249.401, 87.2, 'c'], [258.201, 104.4], [258.201, 104.4, 'c'], [256.601, 120.401, 'c'], [257.001, 125.601], [257.401, 130.801, 'c'], [258.601, 159.201, 'c'], [254.201, 167.201], [249.801, 175.201, 'c'], [260.201, 194.401, 'c'], [262.201, 198.401], [264.201, 202.401, 'c'], [267.801, 213.201, 'c'], [259.001, 204.001], [250.201, 194.801, 'c'], [254.601, 200.401, 'c'], [256.601, 209.201], [258.601, 218.001, 'c'], [264.601, 233.601, 'c'], [263.801, 239.201], [263.801, 239.201, 'c'], [262.601, 240.401, 'c'], [259.401, 236.801], [259.401, 236.801, 'c'], [244.601, 214.001, 'c'], [246.201, 228.401], [246.201, 228.401, 'c'], [245.001, 236.401, 'c'], [241.801, 245.201], [241.801, 245.201, 'c'], [238.601, 256.001, 'c'], [238.601, 247.201], [238.601, 247.201, 'c'], [235.401, 230.401, 'c'], [232.601, 238.001], [229.801, 245.601, 'c'], [226.201, 251.601, 'c'], [223.401, 254.001], [220.601, 256.401, 'c'], [215.401, 233.601, 'c'], [214.201, 244.001], [214.201, 244.001, 'c'], [202.201, 231.601, 'c'], [197.401, 248.001], [185.801, 264.401], [185.801, 264.401, 'c'], [185.401, 252.001, 'c'], [184.201, 258.001], [184.201, 258.001, 'c'], [154.201, 264.001, 'c'], [143.801, 259.601]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[109.401, -97.2], [109.401, -97.2, 'c'], [97.801, -105.2, 'c'], [93.801, -104.8], [89.801, -104.4, 'c'], [121.401, -113.6, 'c'], [162.601, -86], [162.601, -86, 'c'], [167.401, -83.2, 'c'], [171.001, -83.6], [171.001, -83.6, 'c'], [174.201, -81.2, 'c'], [171.401, -77.6], [171.401, -77.6, 'c'], [162.601, -68, 'c'], [173.801, -56.8], [173.801, -56.8, 'c'], [192.201, -50, 'c'], [186.601, -58.8], [186.601, -58.8, 'c'], [197.401, -54.8, 'c'], [199.801, -50.8], [202.201, -46.8, 'c'], [201.001, -50.8, 'c'], [201.001, -50.8], [201.001, -50.8, 'c'], [194.601, -58, 'c'], [188.601, -63.2], [188.601, -63.2, 'c'], [183.401, -65.2, 'c'], [180.601, -73.6], [177.801, -82, 'c'], [175.401, -92, 'c'], [179.801, -95.2], [179.801, -95.2, 'c'], [175.801, -90.8, 'c'], [176.601, -94.8], [177.401, -98.8, 'c'], [181.001, -102.4, 'c'], [182.601, -102.8], [184.201, -103.2, 'c'], [200.601, -119, 'c'], [207.401, -119.4], [207.401, -119.4, 'c'], [198.201, -118, 'c'], [195.201, -119], [192.201, -120, 'c'], [165.601, -131.4, 'c'], [159.601, -132.6], [159.601, -132.6, 'c'], [142.801, -139.2, 'c'], [154.801, -137.2], [154.801, -137.2, 'c'], [190.601, -133.4, 'c'], [208.801, -120.2], [208.801, -120.2, 'c'], [201.601, -128.6, 'c'], [183.201, -135.6], [183.201, -135.6, 'c'], [161.001, -148.2, 'c'], [125.801, -143.2], [125.801, -143.2, 'c'], [108.001, -140, 'c'], [100.201, -138.2], [100.201, -138.2, 'c'], [97.601, -138.8, 'c'], [97.001, -139.2], [96.401, -139.6, 'c'], [84.6, -148.6, 'c'], [57, -141.6], [57, -141.6, 'c'], [40, -137, 'c'], [31.4, -132.2], [31.4, -132.2, 'c'], [16.2, -131, 'c'], [12.6, -127.8], [12.6, -127.8, 'c'], [-6, -113.2, 'c'], [-8, -112.4], [-10, -111.6, 'c'], [-21.4, -104, 'c'], [-22.2, -103.6], [-22.2, -103.6, 'c'], [2.4, -110.2, 'c'], [4.8, -112.6], [7.2, -115, 'c'], [24.6, -117.6, 'c'], [27, -116.2], [29.4, -114.8, 'c'], [37.8, -115.4, 'c'], [28.2, -114.8], [28.2, -114.8, 'c'], [103.801, -100, 'c'], [104.601, -98], [105.401, -96, 'c'], [109.401, -97.2, 'c'], [109.401, -97.2]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[180.801, -106.4], [180.801, -106.4, 'c'], [170.601, -113.8, 'c'], [168.601, -113.8], [166.601, -113.8, 'c'], [154.201, -124, 'c'], [150.001, -123.6], [145.801, -123.2, 'c'], [133.601, -133.2, 'c'], [106.201, -125], [106.201, -125, 'c'], [105.601, -127, 'c'], [109.201, -127.8], [109.201, -127.8, 'c'], [115.601, -130, 'c'], [116.001, -130.6], [116.001, -130.6, 'c'], [136.201, -134.8, 'c'], [143.401, -131.2], [143.401, -131.2, 'c'], [152.601, -128.6, 'c'], [158.801, -122.4], [158.801, -122.4, 'c'], [170.001, -119.2, 'c'], [173.201, -120.2], [173.201, -120.2, 'c'], [182.001, -118, 'c'], [182.401, -116.2], [182.401, -116.2, 'c'], [188.201, -113.2, 'c'], [186.401, -110.6], [186.401, -110.6, 'c'], [186.801, -109, 'c'], [180.801, -106.4]], -closed => 1, -fillcolor => "#cc7226", -filled => 1, -linecolor => "#cc7226"); - -$zinc->add('curve',$top_group,[[168.33, -108.509], [169.137, -107.877, 'c'], [170.156, -107.779, 'c'], [170.761, -106.97], [170.995, -106.656, 'c'], [170.706, -106.33, 'c'], [170.391, -106.233], [169.348, -105.916, 'c'], [168.292, -106.486, 'c'], [167.15, -105.898], [166.748, -105.691, 'c'], [166.106, -105.873, 'c'], [165.553, -106.022], [163.921, -106.463, 'c'], [162.092, -106.488, 'c'], [160.401, -105.8], [158.416, -106.929, 'c'], [156.056, -106.345, 'c'], [153.975, -107.346], [153.917, -107.373, 'c'], [153.695, -107.027, 'c'], [153.621, -107.054], [150.575, -108.199, 'c'], [146.832, -107.916, 'c'], [144.401, -110.2], [141.973, -110.612, 'c'], [139.616, -111.074, 'c'], [137.188, -111.754], [135.37, -112.263, 'c'], [133.961, -113.252, 'c'], [132.341, -114.084], [130.964, -114.792, 'c'], [129.507, -115.314, 'c'], [127.973, -115.686], [126.11, -116.138, 'c'], [124.279, -116.026, 'c'], [122.386, -116.546], [122.293, -116.571, 'c'], [122.101, -116.227, 'c'], [122.019, -116.254], [121.695, -116.362, 'c'], [121.405, -116.945, 'c'], [121.234, -116.892], [119.553, -116.37, 'c'], [118.065, -117.342, 'c'], [116.401, -117], [115.223, -118.224, 'c'], [113.495, -117.979, 'c'], [111.949, -118.421], [108.985, -119.269, 'c'], [105.831, -117.999, 'c'], [102.801, -119], [106.914, -120.842, 'c'], [111.601, -119.61, 'c'], [115.663, -121.679], [117.991, -122.865, 'c'], [120.653, -121.763, 'c'], [123.223, -122.523], [123.71, -122.667, 'c'], [124.401, -122.869, 'c'], [124.801, -122.2], [124.935, -122.335, 'c'], [125.117, -122.574, 'c'], [125.175, -122.546], [127.625, -121.389, 'c'], [129.94, -120.115, 'c'], [132.422, -119.049], [132.763, -118.903, 'c'], [133.295, -119.135, 'c'], [133.547, -118.933], [135.067, -117.717, 'c'], [137.01, -117.82, 'c'], [138.401, -116.6], [140.099, -117.102, 'c'], [141.892, -116.722, 'c'], [143.621, -117.346], [143.698, -117.373, 'c'], [143.932, -117.032, 'c'], [143.965, -117.054], [145.095, -117.802, 'c'], [146.25, -117.531, 'c'], [147.142, -117.227], [147.48, -117.112, 'c'], [148.143, -116.865, 'c'], [148.448, -116.791], [149.574, -116.515, 'c'], [150.43, -116.035, 'c'], [151.609, -115.852], [151.723, -115.834, 'c'], [151.908, -116.174, 'c'], [151.98, -116.146], [153.103, -115.708, 'c'], [154.145, -115.764, 'c'], [154.801, -114.6], [154.936, -114.735, 'c'], [155.101, -114.973, 'c'], [155.183, -114.946], [156.21, -114.608, 'c'], [156.859, -113.853, 'c'], [157.96, -113.612], [158.445, -113.506, 'c'], [159.057, -112.88, 'c'], [159.633, -112.704], [162.025, -111.973, 'c'], [163.868, -110.444, 'c'], [166.062, -109.549], [166.821, -109.239, 'c'], [167.697, -109.005, 'c'], [168.33, -108.509]], -closed => 1, -fillcolor => "#cc7226", -filled => 1, -linecolor => "#cc7226"); - -$zinc->add('curve',$top_group,[[91.696, -122.739], [89.178, -124.464, 'c'], [86.81, -125.57, 'c'], [84.368, -127.356], [84.187, -127.489, 'c'], [83.827, -127.319, 'c'], [83.625, -127.441], [82.618, -128.05, 'c'], [81.73, -128.631, 'c'], [80.748, -129.327], [80.209, -129.709, 'c'], [79.388, -129.698, 'c'], [78.88, -129.956], [76.336, -131.248, 'c'], [73.707, -131.806, 'c'], [71.2, -133], [71.882, -133.638, 'c'], [73.004, -133.394, 'c'], [73.6, -134.2], [73.795, -133.92, 'c'], [74.033, -133.636, 'c'], [74.386, -133.827], [76.064, -134.731, 'c'], [77.914, -134.884, 'c'], [79.59, -134.794], [81.294, -134.702, 'c'], [83.014, -134.397, 'c'], [84.789, -134.125], [85.096, -134.078, 'c'], [85.295, -133.555, 'c'], [85.618, -133.458], [87.846, -132.795, 'c'], [90.235, -133.32, 'c'], [92.354, -132.482], [93.945, -131.853, 'c'], [95.515, -131.03, 'c'], [96.754, -129.755], [97.006, -129.495, 'c'], [96.681, -129.194, 'c'], [96.401, -129], [96.789, -129.109, 'c'], [97.062, -128.903, 'c'], [97.173, -128.59], [97.257, -128.351, 'c'], [97.257, -128.049, 'c'], [97.173, -127.81], [97.061, -127.498, 'c'], [96.782, -127.397, 'c'], [96.408, -127.346], [95.001, -127.156, 'c'], [96.773, -128.536, 'c'], [96.073, -128.088], [94.8, -127.274, 'c'], [95.546, -125.868, 'c'], [94.801, -124.6], [94.521, -124.794, 'c'], [94.291, -125.012, 'c'], [94.401, -125.4], [94.635, -124.878, 'c'], [94.033, -124.588, 'c'], [93.865, -124.272], [93.48, -123.547, 'c'], [92.581, -122.132, 'c'], [91.696, -122.739]], -closed => 1, -fillcolor => "#cc7226", -filled => 1, -linecolor => "#cc7226"); - -$zinc->add('curve',$top_group,[[59.198, -115.391], [56.044, -116.185, 'c'], [52.994, -116.07, 'c'], [49.978, -117.346], [49.911, -117.374, 'c'], [49.688, -117.027, 'c'], [49.624, -117.054], [48.258, -117.648, 'c'], [47.34, -118.614, 'c'], [46.264, -119.66], [45.351, -120.548, 'c'], [43.693, -120.161, 'c'], [42.419, -120.648], [42.095, -120.772, 'c'], [41.892, -121.284, 'c'], [41.591, -121.323], [40.372, -121.48, 'c'], [39.445, -122.429, 'c'], [38.4, -123], [40.736, -123.795, 'c'], [43.147, -123.764, 'c'], [45.609, -124.148], [45.722, -124.166, 'c'], [45.867, -123.845, 'c'], [46, -123.845], [46.136, -123.845, 'c'], [46.266, -124.066, 'c'], [46.4, -124.2], [46.595, -123.92, 'c'], [46.897, -123.594, 'c'], [47.154, -123.848], [47.702, -124.388, 'c'], [48.258, -124.198, 'c'], [48.798, -124.158], [48.942, -124.148, 'c'], [49.067, -123.845, 'c'], [49.2, -123.845], [49.336, -123.845, 'c'], [49.467, -124.156, 'c'], [49.6, -124.156], [49.736, -124.155, 'c'], [49.867, -123.845, 'c'], [50, -123.845], [50.136, -123.845, 'c'], [50.266, -124.066, 'c'], [50.4, -124.2], [51.092, -123.418, 'c'], [51.977, -123.972, 'c'], [52.799, -123.793], [53.837, -123.566, 'c'], [54.104, -122.418, 'c'], [55.178, -122.12], [59.893, -120.816, 'c'], [64.03, -118.671, 'c'], [68.393, -116.584], [68.7, -116.437, 'c'], [68.91, -116.189, 'c'], [68.8, -115.8], [69.067, -115.8, 'c'], [69.38, -115.888, 'c'], [69.57, -115.756], [70.628, -115.024, 'c'], [71.669, -114.476, 'c'], [72.366, -113.378], [72.582, -113.039, 'c'], [72.253, -112.632, 'c'], [72.02, -112.684], [67.591, -113.679, 'c'], [63.585, -114.287, 'c'], [59.198, -115.391]], -closed => 1, -fillcolor => "#cc7226", -filled => 1, -linecolor => "#cc7226"); - -$zinc->add('curve',$top_group,[[45.338, -71.179], [43.746, -72.398, 'c'], [43.162, -74.429, 'c'], [42.034, -76.221], [41.82, -76.561, 'c'], [42.094, -76.875, 'c'], [42.411, -76.964], [42.971, -77.123, 'c'], [43.514, -76.645, 'c'], [43.923, -76.443], [45.668, -75.581, 'c'], [47.203, -74.339, 'c'], [49.2, -74.2], [51.19, -71.966, 'c'], [55.45, -71.581, 'c'], [55.457, -68.2], [55.458, -67.341, 'c'], [54.03, -68.259, 'c'], [53.6, -67.4], [51.149, -68.403, 'c'], [48.76, -68.3, 'c'], [46.38, -69.767], [45.763, -70.148, 'c'], [46.093, -70.601, 'c'], [45.338, -71.179]], -closed => 1, -fillcolor => "#cc7226", -filled => 1, -linecolor => "#cc7226"); - -$zinc->add('curve',$top_group,[[17.8, -123.756], [17.935, -123.755, 'c'], [24.966, -123.522, 'c'], [24.949, -123.408], [24.904, -123.099, 'c'], [17.174, -122.05, 'c'], [16.81, -122.22], [16.646, -122.296, 'c'], [9.134, -119.866, 'c'], [9, -120], [9.268, -120.135, 'c'], [17.534, -123.756, 'c'], [17.8, -123.756]], -closed => 1, -fillcolor => "#cc7226", -filled => 1, -linecolor => "#cc7226"); - -$zinc->add('curve',$top_group,[[33.2, -114], [33.2, -114, 'c'], [18.4, -112.2, 'c'], [14, -111], [9.6, -109.8, 'c'], [-9, -102.2, 'c'], [-12, -100.2], [-12, -100.2, 'c'], [-25.4, -94.8, 'c'], [-42.4, -74.8], [-42.4, -74.8, 'c'], [-34.8, -78.2, 'c'], [-32.6, -81], [-32.6, -81, 'c'], [-19, -93.6, 'c'], [-19.2, -91], [-19.2, -91, 'c'], [-7, -99.6, 'c'], [-7.6, -97.4], [-7.6, -97.4, 'c'], [16.8, -108.6, 'c'], [14.8, -105.4], [14.8, -105.4, 'c'], [36.4, -110, 'c'], [35.4, -108], [35.4, -108, 'c'], [54.2, -103.6, 'c'], [51.4, -103.4], [51.4, -103.4, 'c'], [45.6, -102.2, 'c'], [52, -98.6], [52, -98.6, 'c'], [48.6, -94.2, 'c'], [43.2, -98.2], [37.8, -102.2, 'c'], [40.8, -100, 'c'], [35.8, -99], [35.8, -99, 'c'], [33.2, -98.2, 'c'], [28.6, -102.2], [28.6, -102.2, 'c'], [23, -106.8, 'c'], [14.2, -103.2], [14.2, -103.2, 'c'], [-16.4, -90.6, 'c'], [-18.4, -90], [-18.4, -90, 'c'], [-22, -87.2, 'c'], [-24.4, -83.6], [-24.4, -83.6, 'c'], [-30.2, -79.2, 'c'], [-33.2, -77.8], [-33.2, -77.8, 'c'], [-46, -66.2, 'c'], [-47.2, -64.8], [-47.2, -64.8, 'c'], [-50.6, -59.6, 'c'], [-51.4, -59.2], [-51.4, -59.2, 'c'], [-45, -63, 'c'], [-43, -65], [-43, -65, 'c'], [-29, -75, 'c'], [-23.6, -75.8], [-23.6, -75.8, 'c'], [-19.2, -78.8, 'c'], [-18.4, -80.2], [-18.4, -80.2, 'c'], [-4, -89.4, 'c'], [0.2, -89.4], [0.2, -89.4, 'c'], [9.4, -84.2, 'c'], [11.8, -91.2], [11.8, -91.2, 'c'], [17.6, -93, 'c'], [23.2, -91.8], [23.2, -91.8, 'c'], [26.4, -94.4, 'c'], [25.6, -96.6], [25.6, -96.6, 'c'], [27.2, -98.4, 'c'], [28.2, -94.6], [28.2, -94.6, 'c'], [31.6, -91, 'c'], [36.4, -93], [36.4, -93, 'c'], [40.4, -93.2, 'c'], [38.4, -90.8], [38.4, -90.8, 'c'], [34, -87, 'c'], [22.2, -86.8], [22.2, -86.8, 'c'], [9.8, -86.2, 'c'], [-6.6, -78.6], [-6.6, -78.6, 'c'], [-36.4, -68.2, 'c'], [-45.6, -57.8], [-45.6, -57.8, 'c'], [-52, -49, 'c'], [-57.4, -47.8], [-57.4, -47.8, 'c'], [-63.2, -47, 'c'], [-69.2, -39.6], [-69.2, -39.6, 'c'], [-59.4, -45.4, 'c'], [-50.4, -45.4], [-50.4, -45.4, 'c'], [-46.4, -47.8, 'c'], [-50.2, -44.2], [-50.2, -44.2, 'c'], [-53.8, -36.6, 'c'], [-52.2, -31.2], [-52.2, -31.2, 'c'], [-52.8, -26, 'c'], [-53.6, -24.4], [-53.6, -24.4, 'c'], [-61.4, -11.6, 'c'], [-61.4, -9.2], [-61.4, -6.8, 'c'], [-60.2, 3, 'c'], [-59.8, 3.6], [-59.4, 4.2, 'c'], [-60.8, 2, 'c'], [-57, 4.4], [-53.2, 6.8, 'c'], [-50.4, 8.4, 'c'], [-49.6, 11.2], [-48.8, 14, 'c'], [-51.6, 5.8, 'c'], [-51.8, 4], [-52, 2.2, 'c'], [-56.2, -5, 'c'], [-55.4, -7.4], [-55.4, -7.4, 'c'], [-54.4, -6.4, 'c'], [-53.6, -5], [-53.6, -5, 'c'], [-54.2, -5.6, 'c'], [-53.6, -9.2], [-53.6, -9.2, 'c'], [-52.8, -14.4, 'c'], [-51.4, -17.6], [-50, -20.8, 'c'], [-48, -24.6, 'c'], [-47.6, -25.4], [-47.2, -26.2, 'c'], [-47.2, -32, 'c'], [-45.8, -29.4], [-42.4, -26.8], [-42.4, -26.8, 'c'], [-45.2, -29.4, 'c'], [-43, -31.6], [-43, -31.6, 'c'], [-44, -37.2, 'c'], [-42.2, -39.8], [-42.2, -39.8, 'c'], [-35.2, -48.2, 'c'], [-33.6, -49.2], [-32, -50.2, 'c'], [-33.4, -49.8, 'c'], [-33.4, -49.8], [-33.4, -49.8, 'c'], [-27.4, -54, 'c'], [-33.2, -52.4], [-33.2, -52.4, 'c'], [-37.2, -50.8, 'c'], [-40.2, -50.8], [-40.2, -50.8, 'c'], [-47.8, -48.8, 'c'], [-43.8, -53], [-39.8, -57.2, 'c'], [-29.8, -62.6, 'c'], [-26, -62.4], [-25.2, -60.8], [-14, -63.2], [-15.2, -62.4], [-15.2, -62.4, 'c'], [-15.4, -62.6, 'c'], [-11.2, -63], [-7, -63.4, 'c'], [-1.2, -62, 'c'], [0.2, -63.8], [1.6, -65.6, 'c'], [5, -66.6, 'c'], [4.6, -65.2], [4.2, -63.8, 'c'], [4, -61.8, 'c'], [4, -61.8], [4, -61.8, 'c'], [9, -67.6, 'c'], [8.4, -65.4], [7.8, -63.2, 'c'], [-0.4, -58, 'c'], [-1.8, -51.8], [8.6, -60], [12.2, -63], [12.2, -63, 'c'], [15.8, -60.8, 'c'], [16, -62.4], [16.2, -64, 'c'], [20.8, -69.8, 'c'], [22, -69.6], [23.2, -69.4, 'c'], [25.2, -72.2, 'c'], [25, -69.6], [24.8, -67, 'c'], [32.4, -61.6, 'c'], [32.4, -61.6], [32.4, -61.6, 'c'], [35.6, -63.4, 'c'], [37, -62], [38.4, -60.6, 'c'], [42.6, -81.8, 'c'], [42.6, -81.8], [67.6, -92.4], [111.201, -95.8], [94.201, -102.6], [33.2, -114]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[20.895, 54.407], [22.437, 55.87, 'c'], [49.4, 84.8, 'c'], [49.4, 84.8], [84.6, 121.401, 'c'], [56.6, 87.2, 'c'], [56.6, 87.2], [49, 82.4, 'c'], [39.8, 63.6, 'c'], [39.8, 63.6], [38.6, 60.8, 'c'], [53.8, 70.8, 'c'], [53.8, 70.8], [57.8, 71.6, 'c'], [71.4, 90.8, 'c'], [71.4, 90.8], [64.6, 88.4, 'c'], [69.4, 95.6, 'c'], [69.4, 95.6], [72.2, 97.6, 'c'], [92.601, 113.201, 'c'], [92.601, 113.201], [96.201, 117.201, 'c'], [100.201, 118.801, 'c'], [100.201, 118.801], [114.201, 113.601, 'c'], [107.801, 126.801, 'c'], [107.801, 126.801], [110.201, 133.601, 'c'], [115.801, 122.001, 'c'], [115.801, 122.001], [127.001, 105.2, 'c'], [110.601, 107.601, 'c'], [110.601, 107.601], [80.6, 110.401, 'c'], [73.8, 94.4, 'c'], [73.8, 94.4], [71.4, 92, 'c'], [80.2, 94.4, 'c'], [80.2, 94.4], [88.601, 96.4, 'c'], [73, 82, 'c'], [73, 82], [75.4, 82, 'c'], [84.6, 88.8, 'c'], [84.6, 88.8], [95.001, 98, 'c'], [97.001, 96, 'c'], [97.001, 96], [115.001, 87.2, 'c'], [125.401, 94.8, 'c'], [125.401, 94.8], [127.401, 96.4, 'c'], [121.801, 103.2, 'c'], [123.401, 108.401], [125.001, 113.601, 'c'], [129.801, 126.001, 'c'], [129.801, 126.001], [127.401, 127.601, 'c'], [127.801, 138.401, 'c'], [127.801, 138.401], [144.601, 161.601, 'c'], [135.001, 159.601, 'c'], [135.001, 159.601], [119.401, 159.201, 'c'], [134.201, 166.801, 'c'], [134.201, 166.801], [137.401, 168.801, 'c'], [146.201, 176.001, 'c'], [146.201, 176.001], [143.401, 174.801, 'c'], [141.801, 180.001, 'c'], [141.801, 180.001], [146.601, 184.001, 'c'], [143.801, 188.801, 'c'], [143.801, 188.801], [137.801, 190.001, 'c'], [136.601, 194.001, 'c'], [136.601, 194.001], [143.401, 202.001, 'c'], [133.401, 202.401, 'c'], [133.401, 202.401], [137.001, 206.801, 'c'], [132.201, 218.801, 'c'], [132.201, 218.801], [127.401, 218.801, 'c'], [121.001, 224.401, 'c'], [121.001, 224.401], [123.401, 229.201, 'c'], [113.001, 234.801, 'c'], [113.001, 234.801], [104.601, 236.401, 'c'], [107.401, 243.201, 'c'], [107.401, 243.201], [99.401, 249.201, 'c'], [97.001, 265.201, 'c'], [97.001, 265.201], [96.201, 275.601, 'c'], [93.801, 278.801, 'c'], [99.001, 276.801], [104.201, 274.801, 'c'], [103.401, 262.401, 'c'], [103.401, 262.401], [98.601, 246.801, 'c'], [141.401, 230.801, 'c'], [141.401, 230.801], [145.401, 229.201, 'c'], [146.201, 224.001, 'c'], [146.201, 224.001], [148.201, 224.401, 'c'], [157.001, 232.001, 'c'], [157.001, 232.001], [164.601, 243.201, 'c'], [165.001, 234.001, 'c'], [165.001, 234.001], [166.201, 230.401, 'c'], [164.601, 224.401, 'c'], [164.601, 224.401], [170.601, 202.801, 'c'], [156.601, 196.401, 'c'], [156.601, 196.401], [146.601, 162.801, 'c'], [160.601, 171.201, 'c'], [160.601, 171.201], [163.401, 176.801, 'c'], [174.201, 182.001, 'c'], [174.201, 182.001], [177.801, 179.601], [176.201, 174.801, 'c'], [184.601, 168.801, 'c'], [184.601, 168.801], [187.401, 175.201, 'c'], [193.401, 167.201, 'c'], [193.401, 167.201], [197.001, 142.801, 'c'], [209.401, 157.201, 'c'], [209.401, 157.201], [213.401, 158.401, 'c'], [214.601, 151.601, 'c'], [214.601, 151.601], [218.201, 141.201, 'c'], [214.601, 127.601, 'c'], [214.601, 127.601], [218.201, 127.201, 'c'], [227.801, 133.201, 'c'], [227.801, 133.201], [230.601, 129.601, 'c'], [221.401, 112.801, 'c'], [225.401, 115.201], [229.401, 117.601, 'c'], [233.801, 119.201, 'c'], [233.801, 119.201], [234.601, 117.201, 'c'], [224.601, 104.801, 'c'], [224.601, 104.801], [220.201, 102, 'c'], [215.001, 81.6, 'c'], [215.001, 81.6], [222.201, 85.2, 'c'], [212.201, 70, 'c'], [212.201, 70], [212.201, 66.8, 'c'], [218.201, 55.6, 'c'], [218.201, 55.6], [217.401, 48.8, 'c'], [218.201, 49.2, 'c'], [218.201, 49.2], [221.001, 50.4, 'c'], [229.001, 52, 'c'], [222.201, 45.6], [215.401, 39.2, 'c'], [223.001, 34.4, 'c'], [223.001, 34.4], [227.401, 31.6, 'c'], [213.801, 32, 'c'], [213.801, 32], [208.601, 27.6, 'c'], [209.001, 23.6, 'c'], [209.001, 23.6], [217.001, 25.6, 'c'], [202.601, 11.2, 'c'], [200.201, 7.6], [197.801, 4, 'c'], [207.401, -1.2, 'c'], [207.401, -1.2], [220.601, -4.8, 'c'], [209.001, -8, 'c'], [209.001, -8], [189.401, -7.6, 'c'], [200.201, -18.4, 'c'], [200.201, -18.4], [206.201, -18, 'c'], [204.601, -20.4, 'c'], [204.601, -20.4], [199.401, -21.6, 'c'], [189.801, -28, 'c'], [189.801, -28], [185.801, -31.6, 'c'], [189.401, -30.8, 'c'], [189.401, -30.8], [206.201, -29.6, 'c'], [177.401, -40.8, 'c'], [177.401, -40.8], [185.401, -40.8, 'c'], [167.401, -51.2, 'c'], [167.401, -51.2], [165.401, -52.8, 'c'], [162.201, -60.4, 'c'], [162.201, -60.4], [156.201, -65.6, 'c'], [151.401, -72.4, 'c'], [151.401, -72.4], [151.001, -76.8, 'c'], [146.201, -81.6, 'c'], [146.201, -81.6], [134.601, -95.2, 'c'], [129.001, -94.8, 'c'], [129.001, -94.8], [114.201, -98.4, 'c'], [109.001, -97.6, 'c'], [109.001, -97.6], [56.2, -93.2], [29.8, -80.4, 'c'], [37.6, -59.4, 'c'], [37.6, -59.4], [44, -51, 'c'], [53.2, -54.8, 'c'], [53.2, -54.8], [57.8, -61, 'c'], [69.4, -58.8, 'c'], [69.4, -58.8], [89.801, -55.6, 'c'], [87.201, -59.2, 'c'], [87.201, -59.2], [84.801, -63.8, 'c'], [68.6, -70, 'c'], [68.4, -70.6], [68.2, -71.2, 'c'], [59.4, -74.6, 'c'], [59.4, -74.6], [56.4, -75.8, 'c'], [52, -85, 'c'], [52, -85], [48.8, -88.4, 'c'], [64.6, -82.6, 'c'], [64.6, -82.6], [63.4, -81.6, 'c'], [70.8, -77.6, 'c'], [70.8, -77.6], [88.201, -78.6, 'c'], [98.801, -67.8, 'c'], [98.801, -67.8], [109.601, -51.2, 'c'], [109.801, -59.4, 'c'], [109.801, -59.4], [112.601, -68.8, 'c'], [100.801, -90, 'c'], [100.801, -90], [101.201, -92, 'c'], [109.401, -85.4, 'c'], [109.401, -85.4], [110.801, -87.4, 'c'], [111.601, -81.6, 'c'], [111.601, -81.6], [111.801, -79.2, 'c'], [115.601, -71.2, 'c'], [115.601, -71.2], [118.401, -58.2, 'c'], [122.001, -65.6, 'c'], [122.001, -65.6], [126.601, -56.2], [128.001, -53.6, 'c'], [122.001, -46, 'c'], [122.001, -46], [121.801, -43.2, 'c'], [122.601, -43.4, 'c'], [117.001, -35.8], [111.401, -28.2, 'c'], [114.801, -23.8, 'c'], [114.801, -23.8], [113.401, -17.2, 'c'], [122.201, -17.6, 'c'], [122.201, -17.6], [124.801, -15.4, 'c'], [128.201, -15.4, 'c'], [128.201, -15.4], [130.001, -13.4, 'c'], [132.401, -14, 'c'], [132.401, -14], [134.001, -17.8, 'c'], [140.201, -15.8, 'c'], [140.201, -15.8], [141.601, -18.2, 'c'], [149.801, -18.6, 'c'], [149.801, -18.6], [150.801, -21.2, 'c'], [151.201, -22.8, 'c'], [154.601, -23.4], [158.001, -24, 'c'], [133.401, -67, 'c'], [133.401, -67], [139.801, -67.8, 'c'], [131.601, -80.2, 'c'], [131.601, -80.2], [129.401, -86.8, 'c'], [140.801, -72.2, 'c'], [143.001, -70.8], [145.201, -69.4, 'c'], [146.201, -67.2, 'c'], [144.601, -67.4], [143.001, -67.6, 'c'], [141.201, -65.4, 'c'], [142.601, -65.2], [144.001, -65, 'c'], [157.001, -50, 'c'], [160.401, -39.8], [163.801, -29.6, 'c'], [169.801, -25.6, 'c'], [176.001, -19.6], [182.201, -13.6, 'c'], [181.401, 10.6, 'c'], [181.401, 10.6], [181.001, 19.4, 'c'], [187.001, 30, 'c'], [187.001, 30], [189.001, 33.8, 'c'], [184.801, 52, 'c'], [184.801, 52], [182.801, 54.2, 'c'], [184.201, 55, 'c'], [184.201, 55], [185.201, 56.2, 'c'], [192.001, 69.4, 'c'], [192.001, 69.4], [190.201, 69.2, 'c'], [193.801, 72.8, 'c'], [193.801, 72.8], [199.001, 78.8, 'c'], [192.601, 75.8, 'c'], [192.601, 75.8], [186.601, 74.2, 'c'], [193.601, 84, 'c'], [193.601, 84], [194.801, 85.8, 'c'], [185.801, 81.2, 'c'], [185.801, 81.2], [176.601, 80.6, 'c'], [188.201, 87.8, 'c'], [188.201, 87.8], [196.801, 95, 'c'], [185.401, 90.6, 'c'], [185.401, 90.6], [180.801, 88.8, 'c'], [184.001, 95.6, 'c'], [184.001, 95.6], [187.201, 97.2, 'c'], [204.401, 104.2, 'c'], [204.401, 104.2], [204.801, 108.001, 'c'], [201.801, 113.001, 'c'], [201.801, 113.001], [202.201, 117.001, 'c'], [200.001, 120.401, 'c'], [200.001, 120.401], [198.801, 128.601, 'c'], [198.201, 129.401, 'c'], [198.201, 129.401], [194.001, 129.601, 'c'], [186.601, 143.401, 'c'], [186.601, 143.401], [184.801, 146.001, 'c'], [174.601, 158.001, 'c'], [174.601, 158.001], [172.601, 165.001, 'c'], [154.601, 157.801, 'c'], [154.601, 157.801], [148.001, 161.201, 'c'], [150.001, 157.801, 'c'], [150.001, 157.801], [149.601, 155.601, 'c'], [154.401, 149.601, 'c'], [154.401, 149.601], [161.401, 147.001, 'c'], [158.801, 136.201, 'c'], [158.801, 136.201], [162.801, 134.801, 'c'], [151.601, 132.001, 'c'], [151.801, 130.801], [152.001, 129.601, 'c'], [157.801, 128.201, 'c'], [157.801, 128.201], [165.801, 126.201, 'c'], [161.401, 123.801, 'c'], [161.401, 123.801], [160.801, 119.801, 'c'], [163.801, 114.201, 'c'], [163.801, 114.201], [175.401, 113.401, 'c'], [163.801, 97.2, 'c'], [163.801, 97.2], [153.001, 89.6, 'c'], [152.001, 83.8, 'c'], [152.001, 83.8], [164.601, 75.6, 'c'], [156.401, 63.2, 'c'], [156.601, 59.6], [156.801, 56, 'c'], [158.001, 34.4, 'c'], [158.001, 34.4], [156.001, 28.2, 'c'], [153.001, 14.6, 'c'], [153.001, 14.6], [155.201, 9.4, 'c'], [162.601, -3.2, 'c'], [162.601, -3.2], [165.401, -7.4, 'c'], [174.201, -12.2, 'c'], [172.001, -15.2], [169.801, -18.2, 'c'], [162.001, -16.4, 'c'], [162.001, -16.4], [154.201, -17.8, 'c'], [154.801, -12.6, 'c'], [154.801, -12.6], [153.201, -11.6, 'c'], [152.401, -6.6, 'c'], [152.401, -6.6], [151.68, 1.333, 'c'], [142.801, 7.6, 'c'], [142.801, 7.6], [131.601, 13.8, 'c'], [140.801, 17.8, 'c'], [140.801, 17.8], [146.801, 24.4, 'c'], [137.001, 24.6, 'c'], [137.001, 24.6], [126.001, 22.8, 'c'], [134.201, 33, 'c'], [134.201, 33], [145.001, 45.8, 'c'], [142.001, 48.6, 'c'], [142.001, 48.6], [131.801, 49.6, 'c'], [144.401, 58.8, 'c'], [144.401, 58.8], [144.401, 58.8, 'c'], [143.601, 56.8, 'c'], [143.801, 58.6], [144.001, 60.4, 'c'], [147.001, 64.6, 'c'], [147.801, 66.6], [148.601, 68.6, 'c'], [144.601, 68.8, 'c'], [144.601, 68.8], [145.201, 78.4, 'c'], [129.801, 74.2, 'c'], [129.801, 74.2], [129.801, 74.2, 'c'], [129.801, 74.2, 'c'], [128.201, 74.4], [126.601, 74.6, 'c'], [115.401, 73.8, 'c'], [109.601, 71.6], [103.801, 69.4, 'c'], [97.001, 69.4, 'c'], [97.001, 69.4], [97.001, 69.4, 'c'], [93.001, 71.2, 'c'], [85.4, 71], [77.8, 70.8, 'c'], [69.8, 73.6, 'c'], [69.8, 73.6], [65.4, 73.2, 'c'], [74, 68.8, 'c'], [74.2, 69], [74.4, 69.2, 'c'], [80, 63.6, 'c'], [72, 64.2], [50.203, 65.835, 'c'], [39.4, 55.6, 'c'], [39.4, 55.6], [37.4, 54.2, 'c'], [34.8, 51.4, 'c'], [34.8, 51.4], [24.8, 49.4, 'c'], [36.2, 63.8, 'c'], [36.2, 63.8], [37.4, 65.2, 'c'], [36, 66.2, 'c'], [36, 66.2], [35.2, 64.6, 'c'], [27.4, 59.2, 'c'], [27.4, 59.2], [24.589, 58.227, 'c'], [23.226, 56.893, 'c'], [20.895, 54.407]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-3, 42.8], [-3, 42.8, 'c'], [8.6, 48.4, 'c'], [11.2, 51.2], [13.8, 54, 'c'], [27.8, 65.4, 'c'], [27.8, 65.4], [27.8, 65.4, 'c'], [22.4, 63.4, 'c'], [19.8, 61.6], [17.2, 59.8, 'c'], [6.4, 51.6, 'c'], [6.4, 51.6], [6.4, 51.6, 'c'], [2.6, 45.6, 'c'], [-3, 42.8]], -closed => 1, -fillcolor => "#4c0000", -filled => 1, -linecolor => "#4c0000"); - -$zinc->add('curve',$top_group,[[-61.009, 11.603], [-60.672, 11.455, 'c'], [-61.196, 8.743, 'c'], [-61.4, 8.2], [-62.422, 5.474, 'c'], [-71.4, 4, 'c'], [-71.4, 4], [-71.627, 5.365, 'c'], [-71.682, 6.961, 'c'], [-71.576, 8.599], [-71.576, 8.599, 'c'], [-66.708, 14.118, 'c'], [-61.009, 11.603]], -closed => 1, -fillcolor => "#99cc32", -filled => 1, -linecolor => "#99cc32"); - -$zinc->add('curve',$top_group,[[-61.009, 11.403], [-61.458, 11.561, 'c'], [-61.024, 8.669, 'c'], [-61.2, 8.2], [-62.222, 5.474, 'c'], [-71.4, 3.9, 'c'], [-71.4, 3.9], [-71.627, 5.265, 'c'], [-71.682, 6.861, 'c'], [-71.576, 8.499], [-71.576, 8.499, 'c'], [-67.308, 13.618, 'c'], [-61.009, 11.403]], -closed => 1, -fillcolor => "#659900", -filled => 1, -linecolor => "#659900"); - -$zinc->add('curve',$top_group,[[-65.4, 11.546], [-66.025, 11.546, 'c'], [-66.531, 10.406, 'c'], [-66.531, 9], [-66.531, 7.595, 'c'], [-66.025, 6.455, 'c'], [-65.4, 6.455], [-64.775, 6.455, 'c'], [-64.268, 7.595, 'c'], [-64.268, 9], [-64.268, 10.406, 'c'], [-64.775, 11.546, 'c'], [-65.4, 11.546]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-65.4, 9]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-111, 109.601], [-111, 109.601, 'c'], [-116.6, 119.601, 'c'], [-91.8, 113.601], [-91.8, 113.601, 'c'], [-77.8, 112.401, 'c'], [-75.4, 110.001], [-74.2, 110.801, 'c'], [-65.834, 113.734, 'c'], [-63, 114.401], [-56.2, 116.001, 'c'], [-47.8, 106, 'c'], [-47.8, 106], [-47.8, 106, 'c'], [-43.2, 95.5, 'c'], [-40.4, 95.5], [-37.6, 95.5, 'c'], [-40.8, 97.1, 'c'], [-40.8, 97.1], [-40.8, 97.1, 'c'], [-47.4, 107.201, 'c'], [-47, 108.801], [-47, 108.801, 'c'], [-52.2, 128.801, 'c'], [-68.2, 129.601], [-68.2, 129.601, 'c'], [-84.35, 130.551, 'c'], [-83, 136.401], [-83, 136.401, 'c'], [-74.2, 134.001, 'c'], [-71.8, 136.401], [-71.8, 136.401, 'c'], [-61, 136.001, 'c'], [-69, 142.401], [-75.8, 154.001], [-75.8, 154.001, 'c'], [-75.66, 157.919, 'c'], [-85.8, 154.401], [-95.6, 151.001, 'c'], [-105.9, 138.101, 'c'], [-105.9, 138.101], [-105.9, 138.101, 'c'], [-121.85, 123.551, 'c'], [-111, 109.601]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-112.2, 113.601], [-112.2, 113.601, 'c'], [-114.2, 123.201, 'c'], [-77.4, 112.801], [-77.4, 112.801, 'c'], [-73, 112.801, 'c'], [-70.6, 113.601], [-68.2, 114.401, 'c'], [-56.2, 117.201, 'c'], [-54.2, 116.001], [-54.2, 116.001, 'c'], [-61.4, 129.601, 'c'], [-73, 128.001], [-73, 128.001, 'c'], [-86.2, 129.601, 'c'], [-85.8, 134.401], [-85.8, 134.401, 'c'], [-81.8, 141.601, 'c'], [-77, 144.001], [-77, 144.001, 'c'], [-74.2, 146.401, 'c'], [-74.6, 149.601], [-75, 152.801, 'c'], [-77.8, 154.401, 'c'], [-79.8, 155.201], [-81.8, 156.001, 'c'], [-85, 152.801, 'c'], [-86.6, 152.801], [-88.2, 152.801, 'c'], [-96.6, 146.401, 'c'], [-101, 141.601], [-105.4, 136.801, 'c'], [-113.8, 124.801, 'c'], [-113.4, 122.001], [-113, 119.201, 'c'], [-112.2, 113.601, 'c'], [-112.2, 113.601]], -closed => 1, -fillcolor => "#e59999", -filled => 1, -linecolor => "#e59999"); - -$zinc->add('curve',$top_group,[[-109, 131.051], [-106.4, 135.001, 'c'], [-103.2, 139.201, 'c'], [-101, 141.601], [-96.6, 146.401, 'c'], [-88.2, 152.801, 'c'], [-86.6, 152.801], [-85, 152.801, 'c'], [-81.8, 156.001, 'c'], [-79.8, 155.201], [-77.8, 154.401, 'c'], [-75, 152.801, 'c'], [-74.6, 149.601], [-74.2, 146.401, 'c'], [-77, 144.001, 'c'], [-77, 144.001], [-80.066, 142.468, 'c'], [-82.806, 138.976, 'c'], [-84.385, 136.653], [-84.385, 136.653, 'c'], [-84.2, 139.201, 'c'], [-89.4, 138.401], [-94.6, 137.601, 'c'], [-99.8, 134.801, 'c'], [-101.4, 131.601], [-103, 128.401, 'c'], [-105.4, 126.001, 'c'], [-103.8, 129.601], [-102.2, 133.201, 'c'], [-99.8, 136.801, 'c'], [-98.2, 137.201], [-96.6, 137.601, 'c'], [-97, 138.801, 'c'], [-99.4, 138.401], [-101.8, 138.001, 'c'], [-104.6, 137.601, 'c'], [-109, 132.401]], -closed => 1, -fillcolor => "#b26565", -filled => 1, -linecolor => "#b26565"); - -$zinc->add('curve',$top_group,[[-111.6, 110.001], [-111.6, 110.001, 'c'], [-109.8, 96.4, 'c'], [-108.6, 92.4], [-108.6, 92.4, 'c'], [-109.4, 85.6, 'c'], [-107, 81.4], [-104.6, 77.2, 'c'], [-102.6, 71, 'c'], [-99.6, 65.6], [-96.6, 60.2, 'c'], [-96.4, 56.2, 'c'], [-92.4, 54.6], [-88.4, 53, 'c'], [-82.4, 44.4, 'c'], [-79.6, 43.4], [-76.8, 42.4, 'c'], [-77, 43.2, 'c'], [-77, 43.2], [-77, 43.2, 'c'], [-70.2, 28.4, 'c'], [-56.6, 32.4], [-56.6, 32.4, 'c'], [-72.8, 29.6, 'c'], [-57, 20.2], [-57, 20.2, 'c'], [-61.8, 21.3, 'c'], [-58.5, 14.3], [-56.299, 9.632, 'c'], [-56.8, 16.4, 'c'], [-67.8, 28.2], [-67.8, 28.2, 'c'], [-72.8, 36.8, 'c'], [-78, 39.8], [-83.2, 42.8, 'c'], [-95.2, 49.8, 'c'], [-96.4, 53.6], [-97.6, 57.4, 'c'], [-100.8, 63.2, 'c'], [-102.8, 64.8], [-104.8, 66.4, 'c'], [-107.6, 70.6, 'c'], [-108, 74], [-108, 74, 'c'], [-109.2, 78, 'c'], [-110.6, 79.2], [-112, 80.4, 'c'], [-112.2, 83.6, 'c'], [-112.2, 85.6], [-112.2, 87.6, 'c'], [-114.2, 90.4, 'c'], [-114, 92.8], [-114, 92.8, 'c'], [-113.2, 111.801, 'c'], [-113.6, 113.801], [-111.6, 110.001]], -closed => 1, -fillcolor => "#992600", -filled => 1, -linecolor => "#992600"); - -$zinc->add('curve',$top_group,[[-120.2, 114.601], [-120.2, 114.601, 'c'], [-122.2, 113.201, 'c'], [-126.6, 119.201], [-126.6, 119.201, 'c'], [-119.3, 152.201, 'c'], [-119.3, 153.601], [-119.3, 153.601, 'c'], [-118.2, 151.501, 'c'], [-119.5, 144.301], [-120.8, 137.101, 'c'], [-121.7, 124.401, 'c'], [-121.7, 124.401], [-120.2, 114.601]], -closed => 1, -fillcolor => "#ffffff", -filled => 1, -linecolor => "#ffffff"); - -$zinc->add('curve',$top_group,[[-98.6, 54], [-98.6, 54, 'c'], [-116.2, 57.2, 'c'], [-115.8, 86.4], [-116.6, 111.201], [-116.6, 111.201, 'c'], [-117.8, 85.6, 'c'], [-119, 84], [-120.2, 82.4, 'c'], [-116.2, 71.2, 'c'], [-119.4, 77.2], [-119.4, 77.2, 'c'], [-133.4, 91.2, 'c'], [-125.4, 112.401], [-125.4, 112.401, 'c'], [-123.9, 115.701, 'c'], [-126.9, 111.101], [-126.9, 111.101, 'c'], [-131.5, 98.5, 'c'], [-130.4, 92.1], [-130.4, 92.1, 'c'], [-130.2, 89.9, 'c'], [-128.3, 87.1], [-128.3, 87.1, 'c'], [-119.7, 75.4, 'c'], [-117, 73.1], [-117, 73.1, 'c'], [-115.2, 58.7, 'c'], [-99.8, 53.5], [-99.8, 53.5, 'c'], [-94.1, 51.2, 'c'], [-98.6, 54]], -closed => 1, -fillcolor => "#992600", -filled => 1, -linecolor => "#992600"); - -$zinc->add('curve',$top_group,[[40.8, -12.2], [41.46, -12.554, 'c'], [41.451, -13.524, 'c'], [42.031, -13.697], [43.18, -14.041, 'c'], [43.344, -15.108, 'c'], [43.862, -15.892], [44.735, -17.211, 'c'], [44.928, -18.744, 'c'], [45.51, -20.235], [45.782, -20.935, 'c'], [45.809, -21.89, 'c'], [45.496, -22.55], [44.322, -25.031, 'c'], [43.62, -27.48, 'c'], [42.178, -29.906], [41.91, -30.356, 'c'], [41.648, -31.15, 'c'], [41.447, -31.748], [40.984, -33.132, 'c'], [39.727, -34.123, 'c'], [38.867, -35.443], [38.579, -35.884, 'c'], [39.104, -36.809, 'c'], [38.388, -36.893], [37.491, -36.998, 'c'], [36.042, -37.578, 'c'], [35.809, -36.552], [35.221, -33.965, 'c'], [36.232, -31.442, 'c'], [37.2, -29], [36.418, -28.308, 'c'], [36.752, -27.387, 'c'], [36.904, -26.62], [37.614, -23.014, 'c'], [36.416, -19.662, 'c'], [35.655, -16.188], [35.632, -16.084, 'c'], [35.974, -15.886, 'c'], [35.946, -15.824], [34.724, -13.138, 'c'], [33.272, -10.693, 'c'], [31.453, -8.312], [30.695, -7.32, 'c'], [29.823, -6.404, 'c'], [29.326, -5.341], [28.958, -4.554, 'c'], [28.55, -3.588, 'c'], [28.8, -2.6], [25.365, 0.18, 'c'], [23.115, 4.025, 'c'], [20.504, 7.871], [20.042, 8.551, 'c'], [20.333, 9.76, 'c'], [20.884, 10.029], [21.697, 10.427, 'c'], [22.653, 9.403, 'c'], [23.123, 8.557], [23.512, 7.859, 'c'], [23.865, 7.209, 'c'], [24.356, 6.566], [24.489, 6.391, 'c'], [24.31, 5.972, 'c'], [24.445, 5.851], [27.078, 3.504, 'c'], [28.747, 0.568, 'c'], [31.2, -1.8], [33.15, -2.129, 'c'], [34.687, -3.127, 'c'], [36.435, -4.14], [36.743, -4.319, 'c'], [37.267, -4.07, 'c'], [37.557, -4.265], [39.31, -5.442, 'c'], [39.308, -7.478, 'c'], [39.414, -9.388], [39.464, -10.272, 'c'], [39.66, -11.589, 'c'], [40.8, -12.2]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[31.959, -16.666], [32.083, -16.743, 'c'], [31.928, -17.166, 'c'], [32.037, -17.382], [32.199, -17.706, 'c'], [32.602, -17.894, 'c'], [32.764, -18.218], [32.873, -18.434, 'c'], [32.71, -18.814, 'c'], [32.846, -18.956], [35.179, -21.403, 'c'], [35.436, -24.427, 'c'], [34.4, -27.4], [35.424, -28.02, 'c'], [35.485, -29.282, 'c'], [35.06, -30.129], [34.207, -31.829, 'c'], [34.014, -33.755, 'c'], [33.039, -35.298], [32.237, -36.567, 'c'], [30.659, -37.811, 'c'], [29.288, -36.508], [28.867, -36.108, 'c'], [28.546, -35.321, 'c'], [28.824, -34.609], [28.888, -34.446, 'c'], [29.173, -34.3, 'c'], [29.146, -34.218], [29.039, -33.894, 'c'], [28.493, -33.67, 'c'], [28.487, -33.398], [28.457, -31.902, 'c'], [27.503, -30.391, 'c'], [28.133, -29.062], [28.905, -27.433, 'c'], [29.724, -25.576, 'c'], [30.4, -23.8], [29.166, -21.684, 'c'], [30.199, -19.235, 'c'], [28.446, -17.358], [28.31, -17.212, 'c'], [28.319, -16.826, 'c'], [28.441, -16.624], [28.733, -16.138, 'c'], [29.139, -15.732, 'c'], [29.625, -15.44], [29.827, -15.319, 'c'], [30.175, -15.317, 'c'], [30.375, -15.441], [30.953, -15.803, 'c'], [31.351, -16.29, 'c'], [31.959, -16.666]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[94.771, -26.977], [96.16, -25.185, 'c'], [96.45, -22.39, 'c'], [94.401, -21], [94.951, -17.691, 'c'], [98.302, -19.67, 'c'], [100.401, -20.2], [100.292, -20.588, 'c'], [100.519, -20.932, 'c'], [100.802, -20.937], [101.859, -20.952, 'c'], [102.539, -21.984, 'c'], [103.601, -21.8], [104.035, -23.357, 'c'], [105.673, -24.059, 'c'], [106.317, -25.439], [108.043, -29.134, 'c'], [107.452, -33.407, 'c'], [104.868, -36.653], [104.666, -36.907, 'c'], [104.883, -37.424, 'c'], [104.759, -37.786], [104.003, -39.997, 'c'], [101.935, -40.312, 'c'], [100.001, -41], [98.824, -44.875, 'c'], [98.163, -48.906, 'c'], [96.401, -52.6], [94.787, -52.85, 'c'], [94.089, -54.589, 'c'], [92.752, -55.309], [91.419, -56.028, 'c'], [90.851, -54.449, 'c'], [90.892, -53.403], [90.899, -53.198, 'c'], [91.351, -52.974, 'c'], [91.181, -52.609], [91.105, -52.445, 'c'], [90.845, -52.334, 'c'], [90.845, -52.2], [90.846, -52.065, 'c'], [91.067, -51.934, 'c'], [91.201, -51.8], [90.283, -50.98, 'c'], [88.86, -50.503, 'c'], [88.565, -49.358], [87.611, -45.648, 'c'], [90.184, -42.523, 'c'], [91.852, -39.322], [92.443, -38.187, 'c'], [91.707, -36.916, 'c'], [90.947, -35.708], [90.509, -35.013, 'c'], [90.617, -33.886, 'c'], [90.893, -33.03], [91.645, -30.699, 'c'], [93.236, -28.96, 'c'], [94.771, -26.977]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[57.611, -8.591], [56.124, -6.74, 'c'], [52.712, -4.171, 'c'], [55.629, -2.243], [55.823, -2.114, 'c'], [56.193, -2.11, 'c'], [56.366, -2.244], [58.387, -3.809, 'c'], [60.39, -4.712, 'c'], [62.826, -5.294], [62.95, -5.323, 'c'], [63.224, -4.856, 'c'], [63.593, -5.017], [65.206, -5.72, 'c'], [67.216, -5.662, 'c'], [68.4, -7], [72.167, -6.776, 'c'], [75.732, -7.892, 'c'], [79.123, -9.2], [80.284, -9.648, 'c'], [81.554, -10.207, 'c'], [82.755, -10.709], [84.131, -11.285, 'c'], [85.335, -12.213, 'c'], [86.447, -13.354], [86.58, -13.49, 'c'], [86.934, -13.4, 'c'], [87.201, -13.4], [87.161, -14.263, 'c'], [88.123, -14.39, 'c'], [88.37, -15.012], [88.462, -15.244, 'c'], [88.312, -15.64, 'c'], [88.445, -15.742], [90.583, -17.372, 'c'], [91.503, -19.39, 'c'], [90.334, -21.767], [90.049, -22.345, 'c'], [89.8, -22.963, 'c'], [89.234, -23.439], [88.149, -24.35, 'c'], [87.047, -23.496, 'c'], [86, -23.8], [85.841, -23.172, 'c'], [85.112, -23.344, 'c'], [84.726, -23.146], [83.867, -22.707, 'c'], [82.534, -23.292, 'c'], [81.675, -22.854], [80.313, -22.159, 'c'], [79.072, -21.99, 'c'], [77.65, -21.613], [77.338, -21.531, 'c'], [76.56, -21.627, 'c'], [76.4, -21], [76.266, -21.134, 'c'], [76.118, -21.368, 'c'], [76.012, -21.346], [74.104, -20.95, 'c'], [72.844, -20.736, 'c'], [71.543, -19.044], [71.44, -18.911, 'c'], [70.998, -19.09, 'c'], [70.839, -18.955], [69.882, -18.147, 'c'], [69.477, -16.913, 'c'], [68.376, -16.241], [68.175, -16.118, 'c'], [67.823, -16.286, 'c'], [67.629, -16.157], [66.983, -15.726, 'c'], [66.616, -15.085, 'c'], [65.974, -14.638], [65.645, -14.409, 'c'], [65.245, -14.734, 'c'], [65.277, -14.99], [65.522, -16.937, 'c'], [66.175, -18.724, 'c'], [65.6, -20.6], [67.677, -23.12, 'c'], [70.194, -25.069, 'c'], [72, -27.8], [72.015, -29.966, 'c'], [72.707, -32.112, 'c'], [72.594, -34.189], [72.584, -34.382, 'c'], [72.296, -35.115, 'c'], [72.17, -35.462], [71.858, -36.316, 'c'], [72.764, -37.382, 'c'], [71.92, -38.106], [70.516, -39.309, 'c'], [69.224, -38.433, 'c'], [68.4, -37], [66.562, -36.61, 'c'], [64.496, -35.917, 'c'], [62.918, -37.151], [61.911, -37.938, 'c'], [61.333, -38.844, 'c'], [60.534, -39.9], [59.549, -41.202, 'c'], [59.884, -42.638, 'c'], [59.954, -44.202], [59.96, -44.33, 'c'], [59.645, -44.466, 'c'], [59.645, -44.6], [59.646, -44.735, 'c'], [59.866, -44.866, 'c'], [60, -45], [59.294, -45.626, 'c'], [59.019, -46.684, 'c'], [58, -47], [58.305, -48.092, 'c'], [57.629, -48.976, 'c'], [56.758, -49.278], [54.763, -49.969, 'c'], [53.086, -48.057, 'c'], [51.194, -47.984], [50.68, -47.965, 'c'], [50.213, -49.003, 'c'], [49.564, -49.328], [49.132, -49.544, 'c'], [48.428, -49.577, 'c'], [48.066, -49.311], [47.378, -48.807, 'c'], [46.789, -48.693, 'c'], [46.031, -48.488], [44.414, -48.052, 'c'], [43.136, -46.958, 'c'], [41.656, -46.103], [40.171, -45.246, 'c'], [39.216, -43.809, 'c'], [38.136, -42.489], [37.195, -41.337, 'c'], [37.059, -38.923, 'c'], [38.479, -38.423], [40.322, -37.773, 'c'], [41.626, -40.476, 'c'], [43.592, -40.15], [43.904, -40.099, 'c'], [44.11, -39.788, 'c'], [44, -39.4], [44.389, -39.291, 'c'], [44.607, -39.52, 'c'], [44.8, -39.8], [45.658, -38.781, 'c'], [46.822, -38.444, 'c'], [47.76, -37.571], [48.73, -36.667, 'c'], [50.476, -37.085, 'c'], [51.491, -36.088], [53.02, -34.586, 'c'], [52.461, -31.905, 'c'], [54.4, -30.6], [53.814, -29.287, 'c'], [53.207, -28.01, 'c'], [52.872, -26.583], [52.59, -25.377, 'c'], [53.584, -24.18, 'c'], [54.795, -24.271], [56.053, -24.365, 'c'], [56.315, -25.124, 'c'], [56.8, -26.2], [57.067, -25.933, 'c'], [57.536, -25.636, 'c'], [57.495, -25.42], [57.038, -23.033, 'c'], [56.011, -21.04, 'c'], [55.553, -18.609], [55.494, -18.292, 'c'], [55.189, -18.09, 'c'], [54.8, -18.2], [54.332, -14.051, 'c'], [50.28, -11.657, 'c'], [47.735, -8.492], [47.332, -7.99, 'c'], [47.328, -6.741, 'c'], [47.737, -6.338], [49.14, -4.951, 'c'], [51.1, -6.497, 'c'], [52.8, -7], [53.013, -8.206, 'c'], [53.872, -9.148, 'c'], [55.204, -9.092], [55.46, -9.082, 'c'], [55.695, -9.624, 'c'], [56.019, -9.754], [56.367, -9.892, 'c'], [56.869, -9.668, 'c'], [57.155, -9.866], [58.884, -11.061, 'c'], [60.292, -12.167, 'c'], [62.03, -13.356], [62.222, -13.487, 'c'], [62.566, -13.328, 'c'], [62.782, -13.436], [63.107, -13.598, 'c'], [63.294, -13.985, 'c'], [63.617, -14.17], [63.965, -14.37, 'c'], [64.207, -14.08, 'c'], [64.4, -13.8], [63.754, -13.451, 'c'], [63.75, -12.494, 'c'], [63.168, -12.292], [62.393, -12.024, 'c'], [61.832, -11.511, 'c'], [61.158, -11.064], [60.866, -10.871, 'c'], [60.207, -11.119, 'c'], [60.103, -10.94], [59.505, -9.912, 'c'], [58.321, -9.474, 'c'], [57.611, -8.591]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[2.2, -58], [2.2, -58, 'c'], [-7.038, -60.872, 'c'], [-18.2, -35.2], [-18.2, -35.2, 'c'], [-20.6, -30, 'c'], [-23, -28], [-25.4, -26, 'c'], [-36.6, -22.4, 'c'], [-38.6, -18.4], [-49, -2.4], [-49, -2.4, 'c'], [-34.2, -18.4, 'c'], [-31, -20.8], [-31, -20.8, 'c'], [-23, -29.2, 'c'], [-26.2, -22.4], [-26.2, -22.4, 'c'], [-40.2, -11.6, 'c'], [-39, -2.4], [-39, -2.4, 'c'], [-44.6, 12, 'c'], [-45.4, 14], [-45.4, 14, 'c'], [-29.4, -18, 'c'], [-27, -19.2], [-24.6, -20.4, 'c'], [-23.4, -20.4, 'c'], [-24.6, -16.8], [-25.8, -13.2, 'c'], [-26.2, 3.2, 'c'], [-29, 5.2], [-29, 5.2, 'c'], [-21, -15.2, 'c'], [-21.8, -18.4], [-21.8, -18.4, 'c'], [-18.6, -22, 'c'], [-16.2, -16.8], [-17.4, -0.8], [-13, 11.2], [-13, 11.2, 'c'], [-15.4, 0, 'c'], [-13.8, -15.6], [-13.8, -15.6, 'c'], [-15.8, -26, 'c'], [-11.8, -20.4], [-7.8, -14.8, 'c'], [1.8, -8.8, 'c'], [1.8, -4], [1.8, -4, 'c'], [-3.4, -21.6, 'c'], [-12.6, -26.4], [-16.6, -20.4], [-17.8, -22.4], [-17.8, -22.4, 'c'], [-21.4, -23.2, 'c'], [-17, -30], [-12.6, -36.8, 'c'], [-13, -37.6, 'c'], [-13, -37.6], [-13, -37.6, 'c'], [-6.6, -30.4, 'c'], [-5, -30.4], [-5, -30.4, 'c'], [8.2, -38, 'c'], [9.4, -13.6], [9.4, -13.6, 'c'], [16.2, -28, 'c'], [7, -34.8], [7, -34.8, 'c'], [-7.8, -36.8, 'c'], [-6.6, -42], [0.6, -54.4], [4.2, -59.6, 'c'], [2.6, -56.8, 'c'], [2.6, -56.8]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-17.8, -41.6], [-17.8, -41.6, 'c'], [-30.6, -41.6, 'c'], [-33.8, -36.4], [-41, -26.8], [-41, -26.8, 'c'], [-23.8, -36.8, 'c'], [-19.8, -38], [-15.8, -39.2, 'c'], [-17.8, -41.6, 'c'], [-17.8, -41.6]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-57.8, -35.2], [-57.8, -35.2, 'c'], [-59.8, -34, 'c'], [-60.2, -31.2], [-60.6, -28.4, 'c'], [-63, -28, 'c'], [-62.2, -25.2], [-61.4, -22.4, 'c'], [-59.4, -20, 'c'], [-59.4, -24], [-59.4, -28, 'c'], [-57.8, -30, 'c'], [-57, -31.2], [-56.2, -32.4, 'c'], [-54.6, -36.8, 'c'], [-57.8, -35.2]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-66.6, 26], [-66.6, 26, 'c'], [-75, 22, 'c'], [-78.2, 18.4], [-81.4, 14.8, 'c'], [-80.948, 19.966, 'c'], [-85.8, 19.6], [-91.647, 19.159, 'c'], [-90.6, 3.2, 'c'], [-90.6, 3.2], [-94.6, 10.8], [-94.6, 10.8, 'c'], [-95.8, 25.2, 'c'], [-87.8, 22.8], [-83.893, 21.628, 'c'], [-82.6, 23.2, 'c'], [-84.2, 24], [-85.8, 24.8, 'c'], [-78.6, 25.2, 'c'], [-81.4, 26.8], [-84.2, 28.4, 'c'], [-69.8, 23.2, 'c'], [-72.2, 33.6], [-66.6, 26]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-79.2, 40.4], [-79.2, 40.4, 'c'], [-94.6, 44.8, 'c'], [-98.2, 35.2], [-98.2, 35.2, 'c'], [-103, 37.6, 'c'], [-100.8, 40.6], [-98.6, 43.6, 'c'], [-97.4, 44, 'c'], [-97.4, 44], [-97.4, 44, 'c'], [-92, 45.2, 'c'], [-92.6, 46], [-93.2, 46.8, 'c'], [-95.6, 50.2, 'c'], [-95.6, 50.2], [-95.6, 50.2, 'c'], [-85.4, 44.2, 'c'], [-79.2, 40.4]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[149.201, 118.601], [148.774, 120.735, 'c'], [147.103, 121.536, 'c'], [145.201, 122.201], [143.284, 121.243, 'c'], [140.686, 118.137, 'c'], [138.801, 120.201], [138.327, 119.721, 'c'], [137.548, 119.661, 'c'], [137.204, 118.999], [136.739, 118.101, 'c'], [137.011, 117.055, 'c'], [136.669, 116.257], [136.124, 114.985, 'c'], [135.415, 113.619, 'c'], [135.601, 112.201], [137.407, 111.489, 'c'], [138.002, 109.583, 'c'], [137.528, 107.82], [137.459, 107.563, 'c'], [137.03, 107.366, 'c'], [137.23, 107.017], [137.416, 106.694, 'c'], [137.734, 106.467, 'c'], [138.001, 106.2], [137.866, 106.335, 'c'], [137.721, 106.568, 'c'], [137.61, 106.548], [137, 106.442, 'c'], [137.124, 105.805, 'c'], [137.254, 105.418], [137.839, 103.672, 'c'], [139.853, 103.408, 'c'], [141.201, 104.6], [141.457, 104.035, 'c'], [141.966, 104.229, 'c'], [142.401, 104.2], [142.351, 103.621, 'c'], [142.759, 103.094, 'c'], [142.957, 102.674], [143.475, 101.576, 'c'], [145.104, 102.682, 'c'], [145.901, 102.07], [146.977, 101.245, 'c'], [148.04, 100.546, 'c'], [149.118, 101.149], [150.927, 102.162, 'c'], [152.636, 103.374, 'c'], [153.835, 105.115], [154.41, 105.949, 'c'], [154.65, 107.23, 'c'], [154.592, 108.188], [154.554, 108.835, 'c'], [153.173, 108.483, 'c'], [152.83, 109.412], [152.185, 111.16, 'c'], [154.016, 111.679, 'c'], [154.772, 113.017], [154.97, 113.366, 'c'], [154.706, 113.67, 'c'], [154.391, 113.768], [153.98, 113.896, 'c'], [153.196, 113.707, 'c'], [153.334, 114.16], [154.306, 117.353, 'c'], [151.55, 118.031, 'c'], [149.201, 118.601]], -closed => 1, -fillcolor => "#ffffff", -filled => 1, -linecolor => "#ffffff"); - -$zinc->add('curve',$top_group,[[139.6, 138.201], [139.593, 136.463, 'c'], [137.992, 134.707, 'c'], [139.201, 133.001], [139.336, 133.135, 'c'], [139.467, 133.356, 'c'], [139.601, 133.356], [139.736, 133.356, 'c'], [139.867, 133.135, 'c'], [140.001, 133.001], [141.496, 135.217, 'c'], [145.148, 136.145, 'c'], [145.006, 138.991], [144.984, 139.438, 'c'], [143.897, 140.356, 'c'], [144.801, 141.001], [142.988, 142.349, 'c'], [142.933, 144.719, 'c'], [142.001, 146.601], [140.763, 146.315, 'c'], [139.551, 145.952, 'c'], [138.401, 145.401], [138.753, 143.915, 'c'], [138.636, 142.231, 'c'], [139.456, 140.911], [139.89, 140.213, 'c'], [139.603, 139.134, 'c'], [139.6, 138.201]], -closed => 1, -fillcolor => "#ffffff", -filled => 1, -linecolor => "#ffffff"); - -$zinc->add('curve',$top_group,[[-26.6, 129.201], [-26.6, 129.201, 'c'], [-43.458, 139.337, 'c'], [-29.4, 124.001], [-20.6, 114.401, 'c'], [-10.6, 108.801, 'c'], [-10.6, 108.801], [-10.6, 108.801, 'c'], [-0.2, 104.4, 'c'], [3.4, 103.2], [7, 102, 'c'], [22.2, 96.8, 'c'], [25.4, 96.4], [28.6, 96, 'c'], [38.2, 92, 'c'], [45, 96], [51.8, 100, 'c'], [59.8, 104.4, 'c'], [59.8, 104.4], [59.8, 104.4, 'c'], [43.4, 96, 'c'], [39.8, 98.4], [36.2, 100.8, 'c'], [29, 100.4, 'c'], [23, 103.6], [23, 103.6, 'c'], [8.2, 108.001, 'c'], [5, 110.001], [1.8, 112.001, 'c'], [-8.6, 123.601, 'c'], [-10.2, 122.801], [-11.8, 122.001, 'c'], [-9.8, 121.601, 'c'], [-8.6, 118.801], [-7.4, 116.001, 'c'], [-9.4, 114.401, 'c'], [-17.4, 120.801], [-25.4, 127.201, 'c'], [-26.6, 129.201, 'c'], [-26.6, 129.201]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-19.195, 123.234], [-19.195, 123.234, 'c'], [-17.785, 110.194, 'c'], [-9.307, 111.859], [-9.307, 111.859, 'c'], [-1.081, 107.689, 'c'], [1.641, 105.721], [1.641, 105.721, 'c'], [9.78, 104.019, 'c'], [11.09, 103.402], [29.569, 94.702, 'c'], [44.288, 99.221, 'c'], [44.835, 98.101], [45.381, 96.982, 'c'], [65.006, 104.099, 'c'], [68.615, 108.185], [69.006, 108.628, 'c'], [58.384, 102.588, 'c'], [48.686, 100.697], [40.413, 99.083, 'c'], [18.811, 100.944, 'c'], [7.905, 106.48], [4.932, 107.989, 'c'], [-4.013, 113.773, 'c'], [-6.544, 113.662], [-9.075, 113.55, 'c'], [-19.195, 123.234, 'c'], [-19.195, 123.234]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-23, 148.801], [-23, 148.801, 'c'], [-38.2, 146.401, 'c'], [-21.4, 144.801], [-21.4, 144.801, 'c'], [-3.4, 142.801, 'c'], [0.6, 137.601], [0.6, 137.601, 'c'], [14.2, 128.401, 'c'], [17, 128.001], [19.8, 127.601, 'c'], [49.8, 120.401, 'c'], [50.2, 118.001], [50.6, 115.601, 'c'], [56.2, 115.601, 'c'], [57.8, 116.401], [59.4, 117.201, 'c'], [58.6, 118.401, 'c'], [55.8, 119.201], [53, 120.001, 'c'], [21.8, 136.401, 'c'], [15.4, 137.601], [9, 138.801, 'c'], [-2.6, 146.401, 'c'], [-7.4, 147.601], [-12.2, 148.801, 'c'], [-23, 148.801, 'c'], [-23, 148.801]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-3.48, 141.403], [-3.48, 141.403, 'c'], [-12.062, 140.574, 'c'], [-3.461, 139.755], [-3.461, 139.755, 'c'], [5.355, 136.331, 'c'], [7.403, 133.668], [7.403, 133.668, 'c'], [14.367, 128.957, 'c'], [15.8, 128.753], [17.234, 128.548, 'c'], [31.194, 124.861, 'c'], [31.399, 123.633], [31.604, 122.404, 'c'], [65.67, 109.823, 'c'], [70.09, 113.013], [73.001, 115.114, 'c'], [63.1, 113.437, 'c'], [53.466, 117.847], [52.111, 118.467, 'c'], [18.258, 133.054, 'c'], [14.981, 133.668], [11.704, 134.283, 'c'], [5.765, 138.174, 'c'], [3.307, 138.788], [0.85, 139.403, 'c'], [-3.48, 141.403, 'c'], [-3.48, 141.403]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-11.4, 143.601], [-11.4, 143.601, 'c'], [-6.2, 143.201, 'c'], [-7.4, 144.801], [-8.6, 146.401, 'c'], [-11, 145.601, 'c'], [-11, 145.601], [-11.4, 143.601]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-18.6, 145.201], [-18.6, 145.201, 'c'], [-13.4, 144.801, 'c'], [-14.6, 146.401], [-15.8, 148.001, 'c'], [-18.2, 147.201, 'c'], [-18.2, 147.201], [-18.6, 145.201]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-29, 146.801], [-29, 146.801, 'c'], [-23.8, 146.401, 'c'], [-25, 148.001], [-26.2, 149.601, 'c'], [-28.6, 148.801, 'c'], [-28.6, 148.801], [-29, 146.801]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-36.6, 147.601], [-36.6, 147.601, 'c'], [-31.4, 147.201, 'c'], [-32.6, 148.801], [-33.8, 150.401, 'c'], [-36.2, 149.601, 'c'], [-36.2, 149.601], [-36.6, 147.601]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[1.8, 108.001], [1.8, 108.001, 'c'], [6.2, 108.001, 'c'], [5, 109.601], [3.8, 111.201, 'c'], [0.6, 110.801, 'c'], [0.6, 110.801], [1.8, 108.001]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-8.2, 113.601], [-8.2, 113.601, 'c'], [-1.694, 111.46, 'c'], [-4.2, 114.801], [-5.4, 116.401, 'c'], [-7.8, 115.601, 'c'], [-7.8, 115.601], [-8.2, 113.601]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-19.4, 118.401], [-19.4, 118.401, 'c'], [-14.2, 118.001, 'c'], [-15.4, 119.601], [-16.6, 121.201, 'c'], [-19, 120.401, 'c'], [-19, 120.401], [-19.4, 118.401]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-27, 124.401], [-27, 124.401, 'c'], [-21.8, 124.001, 'c'], [-23, 125.601], [-24.2, 127.201, 'c'], [-26.6, 126.401, 'c'], [-26.6, 126.401], [-27, 124.401]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-33.8, 129.201], [-33.8, 129.201, 'c'], [-28.6, 128.801, 'c'], [-29.8, 130.401], [-31, 132.001, 'c'], [-33.4, 131.201, 'c'], [-33.4, 131.201], [-33.8, 129.201]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[5.282, 135.598], [5.282, 135.598, 'c'], [12.203, 135.066, 'c'], [10.606, 137.195], [9.009, 139.325, 'c'], [5.814, 138.26, 'c'], [5.814, 138.26], [5.282, 135.598]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[15.682, 130.798], [15.682, 130.798, 'c'], [22.603, 130.266, 'c'], [21.006, 132.395], [19.409, 134.525, 'c'], [16.214, 133.46, 'c'], [16.214, 133.46], [15.682, 130.798]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[26.482, 126.398], [26.482, 126.398, 'c'], [33.403, 125.866, 'c'], [31.806, 127.995], [30.209, 130.125, 'c'], [27.014, 129.06, 'c'], [27.014, 129.06], [26.482, 126.398]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[36.882, 121.598], [36.882, 121.598, 'c'], [43.803, 121.066, 'c'], [42.206, 123.195], [40.609, 125.325, 'c'], [37.414, 124.26, 'c'], [37.414, 124.26], [36.882, 121.598]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[9.282, 103.598], [9.282, 103.598, 'c'], [16.203, 103.066, 'c'], [14.606, 105.195], [13.009, 107.325, 'c'], [9.014, 107.06, 'c'], [9.014, 107.06], [9.282, 103.598]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[19.282, 100.398], [19.282, 100.398, 'c'], [26.203, 99.866, 'c'], [24.606, 101.995], [23.009, 104.125, 'c'], [18.614, 103.86, 'c'], [18.614, 103.86], [19.282, 100.398]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-3.4, 140.401], [-3.4, 140.401, 'c'], [1.8, 140.001, 'c'], [0.6, 141.601], [-0.6, 143.201, 'c'], [-3, 142.401, 'c'], [-3, 142.401], [-3.4, 140.401]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-76.6, 41.2], [-76.6, 41.2, 'c'], [-81, 50, 'c'], [-81.4, 53.2], [-81.4, 53.2, 'c'], [-80.6, 44.4, 'c'], [-79.4, 42.4], [-78.2, 40.4, 'c'], [-76.6, 41.2, 'c'], [-76.6, 41.2]], -closed => 1, -fillcolor => "#992600", -filled => 1, -linecolor => "#992600"); - -$zinc->add('curve',$top_group,[[-95, 55.2], [-95, 55.2, 'c'], [-98.2, 69.6, 'c'], [-97.8, 72.4], [-97.8, 72.4, 'c'], [-99, 60.8, 'c'], [-98.6, 59.6], [-98.2, 58.4, 'c'], [-95, 55.2, 'c'], [-95, 55.2]], -closed => 1, -fillcolor => "#992600", -filled => 1, -linecolor => "#992600"); - -$zinc->add('curve',$top_group,[[-74.2, -19.4], [-74.4, -16.2], [-76.6, -16], [-76.6, -16, 'c'], [-62.4, -3.4, 'c'], [-61.8, 4.2], [-61.8, 4.2, 'c'], [-61, -4, 'c'], [-74.2, -19.4]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-70.216, -18.135], [-70.647, -18.551, 'c'], [-70.428, -19.296, 'c'], [-70.836, -19.556], [-71.645, -20.072, 'c'], [-69.538, -20.129, 'c'], [-69.766, -20.845], [-70.149, -22.051, 'c'], [-69.962, -22.072, 'c'], [-70.084, -23.348], [-70.141, -23.946, 'c'], [-69.553, -25.486, 'c'], [-69.168, -25.926], [-67.722, -27.578, 'c'], [-69.046, -30.51, 'c'], [-67.406, -32.061], [-67.102, -32.35, 'c'], [-66.726, -32.902, 'c'], [-66.441, -33.32], [-65.782, -34.283, 'c'], [-64.598, -34.771, 'c'], [-63.648, -35.599], [-63.33, -35.875, 'c'], [-63.531, -36.702, 'c'], [-62.962, -36.61], [-62.248, -36.495, 'c'], [-61.007, -36.625, 'c'], [-61.052, -35.784], [-61.165, -33.664, 'c'], [-62.494, -31.944, 'c'], [-63.774, -30.276], [-63.323, -29.572, 'c'], [-63.781, -28.937, 'c'], [-64.065, -28.38], [-65.4, -25.76, 'c'], [-65.211, -22.919, 'c'], [-65.385, -20.079], [-65.39, -19.994, 'c'], [-65.697, -19.916, 'c'], [-65.689, -19.863], [-65.336, -17.528, 'c'], [-64.752, -15.329, 'c'], [-63.873, -13.1], [-63.507, -12.17, 'c'], [-63.036, -11.275, 'c'], [-62.886, -10.348], [-62.775, -9.662, 'c'], [-62.672, -8.829, 'c'], [-63.08, -8.124], [-61.045, -5.234, 'c'], [-62.354, -2.583, 'c'], [-61.185, 0.948], [-60.978, 1.573, 'c'], [-59.286, 3.487, 'c'], [-59.749, 3.326], [-62.262, 2.455, 'c'], [-62.374, 2.057, 'c'], [-62.551, 1.304], [-62.697, 0.681, 'c'], [-63.027, -0.696, 'c'], [-63.264, -1.298], [-63.328, -1.462, 'c'], [-63.499, -3.346, 'c'], [-63.577, -3.468], [-65.09, -5.85, 'c'], [-63.732, -5.674, 'c'], [-65.102, -8.032], [-66.53, -8.712, 'c'], [-67.496, -9.816, 'c'], [-68.619, -10.978], [-68.817, -11.182, 'c'], [-67.674, -11.906, 'c'], [-67.855, -12.119], [-68.947, -13.408, 'c'], [-70.1, -14.175, 'c'], [-69.764, -15.668], [-69.609, -16.358, 'c'], [-69.472, -17.415, 'c'], [-70.216, -18.135]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-73.8, -16.4], [-73.8, -16.4, 'c'], [-73.4, -9.6, 'c'], [-71, -8], [-68.6, -6.4, 'c'], [-69.8, -7.2, 'c'], [-73, -8.4], [-76.2, -9.6, 'c'], [-75, -10.4, 'c'], [-75, -10.4], [-75, -10.4, 'c'], [-77.8, -10, 'c'], [-75.4, -8], [-73, -6, 'c'], [-69.4, -3.6, 'c'], [-71, -3.6], [-72.6, -3.6, 'c'], [-80.2, -7.6, 'c'], [-80.2, -10.4], [-80.2, -13.2, 'c'], [-81.2, -17.3, 'c'], [-81.2, -17.3], [-81.2, -17.3, 'c'], [-80.1, -18.1, 'c'], [-75.3, -18], [-75.3, -18, 'c'], [-73.9, -17.3, 'c'], [-73.8, -16.4]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-74.6, 2.2], [-74.6, 2.2, 'c'], [-83.12, -0.591, 'c'], [-101.6, 2.8], [-101.6, 2.8, 'c'], [-92.569, 0.722, 'c'], [-73.8, 3], [-63.5, 4.25, 'c'], [-74.6, 2.2, 'c'], [-74.6, 2.2]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-72.502, 2.129], [-72.502, 2.129, 'c'], [-80.748, -1.389, 'c'], [-99.453, 0.392], [-99.453, 0.392, 'c'], [-90.275, -0.897, 'c'], [-71.774, 2.995], [-61.62, 5.131, 'c'], [-72.502, 2.129, 'c'], [-72.502, 2.129]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-70.714, 2.222], [-70.714, 2.222, 'c'], [-78.676, -1.899, 'c'], [-97.461, -1.514], [-97.461, -1.514, 'c'], [-88.213, -2.118, 'c'], [-70.052, 3.14], [-60.086, 6.025, 'c'], [-70.714, 2.222, 'c'], [-70.714, 2.222]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-69.444, 2.445], [-69.444, 2.445, 'c'], [-76.268, -1.862, 'c'], [-93.142, -2.96], [-93.142, -2.96, 'c'], [-84.803, -2.79, 'c'], [-68.922, 3.319], [-60.206, 6.672, 'c'], [-69.444, 2.445, 'c'], [-69.444, 2.445]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[45.84, 12.961], [45.84, 12.961, 'c'], [44.91, 13.605, 'c'], [45.124, 12.424], [45.339, 11.243, 'c'], [73.547, -1.927, 'c'], [77.161, -1.677], [77.161, -1.677, 'c'], [46.913, 11.529, 'c'], [45.84, 12.961]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[42.446, 13.6], [42.446, 13.6, 'c'], [41.57, 14.315, 'c'], [41.691, 13.121], [41.812, 11.927, 'c'], [68.899, -3.418, 'c'], [72.521, -3.452], [72.521, -3.452, 'c'], [43.404, 12.089, 'c'], [42.446, 13.6]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[39.16, 14.975], [39.16, 14.975, 'c'], [38.332, 15.747, 'c'], [38.374, 14.547], [38.416, 13.348, 'c'], [58.233, -2.149, 'c'], [68.045, -4.023], [68.045, -4.023, 'c'], [50.015, 4.104, 'c'], [39.16, 14.975]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[36.284, 16.838], [36.284, 16.838, 'c'], [35.539, 17.532, 'c'], [35.577, 16.453], [35.615, 15.373, 'c'], [53.449, 1.426, 'c'], [62.28, -0.26], [62.28, -0.26, 'c'], [46.054, 7.054, 'c'], [36.284, 16.838]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[4.6, 164.801], [4.6, 164.801, 'c'], [-10.6, 162.401, 'c'], [6.2, 160.801], [6.2, 160.801, 'c'], [24.2, 158.801, 'c'], [28.2, 153.601], [28.2, 153.601, 'c'], [41.8, 144.401, 'c'], [44.6, 144.001], [47.4, 143.601, 'c'], [63.8, 140.001, 'c'], [64.2, 137.601], [64.6, 135.201, 'c'], [70.6, 132.801, 'c'], [72.2, 133.601], [73.8, 134.401, 'c'], [73.8, 143.601, 'c'], [71, 144.401], [68.2, 145.201, 'c'], [49.4, 152.401, 'c'], [43, 153.601], [36.6, 154.801, 'c'], [25, 162.401, 'c'], [20.2, 163.601], [15.4, 164.801, 'c'], [4.6, 164.801, 'c'], [4.6, 164.801]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[77.6, 127.401], [77.6, 127.401, 'c'], [74.6, 129.001, 'c'], [73.4, 131.601], [73.4, 131.601, 'c'], [67, 142.201, 'c'], [52.8, 145.401], [52.8, 145.401, 'c'], [29.8, 154.401, 'c'], [22, 156.401], [22, 156.401, 'c'], [8.6, 161.401, 'c'], [1.2, 160.601], [1.2, 160.601, 'c'], [-5.8, 160.801, 'c'], [0.4, 162.401], [0.4, 162.401, 'c'], [20.6, 160.401, 'c'], [24, 158.601], [24, 158.601, 'c'], [39.6, 153.401, 'c'], [42.6, 150.801], [45.6, 148.201, 'c'], [63.8, 143.201, 'c'], [66, 141.201], [68.2, 139.201, 'c'], [78, 130.801, 'c'], [77.6, 127.401]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[18.882, 158.911], [18.882, 158.911, 'c'], [24.111, 158.685, 'c'], [22.958, 160.234], [21.805, 161.784, 'c'], [19.357, 160.91, 'c'], [19.357, 160.91], [18.882, 158.911]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[11.68, 160.263], [11.68, 160.263, 'c'], [16.908, 160.037, 'c'], [15.756, 161.586], [14.603, 163.136, 'c'], [12.155, 162.263, 'c'], [12.155, 162.263], [11.68, 160.263]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[1.251, 161.511], [1.251, 161.511, 'c'], [6.48, 161.284, 'c'], [5.327, 162.834], [4.174, 164.383, 'c'], [1.726, 163.51, 'c'], [1.726, 163.51], [1.251, 161.511]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-6.383, 162.055], [-6.383, 162.055, 'c'], [-1.154, 161.829, 'c'], [-2.307, 163.378], [-3.46, 164.928, 'c'], [-5.908, 164.054, 'c'], [-5.908, 164.054], [-6.383, 162.055]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[35.415, 151.513], [35.415, 151.513, 'c'], [42.375, 151.212, 'c'], [40.84, 153.274], [39.306, 155.336, 'c'], [36.047, 154.174, 'c'], [36.047, 154.174], [35.415, 151.513]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[45.73, 147.088], [45.73, 147.088, 'c'], [51.689, 143.787, 'c'], [51.155, 148.849], [50.885, 151.405, 'c'], [46.362, 149.749, 'c'], [46.362, 149.749], [45.73, 147.088]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[54.862, 144.274], [54.862, 144.274, 'c'], [62.021, 140.573, 'c'], [60.287, 146.035], [59.509, 148.485, 'c'], [55.493, 146.935, 'c'], [55.493, 146.935], [54.862, 144.274]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[64.376, 139.449], [64.376, 139.449, 'c'], [68.735, 134.548, 'c'], [69.801, 141.21], [70.207, 143.748, 'c'], [65.008, 142.11, 'c'], [65.008, 142.11], [64.376, 139.449]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[26.834, 155.997], [26.834, 155.997, 'c'], [32.062, 155.77, 'c'], [30.91, 157.32], [29.757, 158.869, 'c'], [27.308, 157.996, 'c'], [27.308, 157.996], [26.834, 155.997]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[62.434, 34.603], [62.434, 34.603, 'c'], [61.708, 35.268, 'c'], [61.707, 34.197], [61.707, 33.127, 'c'], [79.191, 19.863, 'c'], [88.034, 18.479], [88.034, 18.479, 'c'], [71.935, 25.208, 'c'], [62.434, 34.603]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[65.4, 98.4], [65.4, 98.4, 'c'], [87.401, 120.801, 'c'], [96.601, 124.401], [96.601, 124.401, 'c'], [105.801, 135.601, 'c'], [101.801, 161.601], [101.801, 161.601, 'c'], [98.601, 169.201, 'c'], [95.401, 148.401], [95.401, 148.401, 'c'], [98.601, 123.201, 'c'], [87.401, 139.201], [87.401, 139.201, 'c'], [79, 129.301, 'c'], [85.4, 129.601], [85.4, 129.601, 'c'], [88.601, 131.601, 'c'], [89.001, 130.001], [89.401, 128.401, 'c'], [81.4, 114.801, 'c'], [64.2, 100.4], [47, 86, 'c'], [65.4, 98.4, 'c'], [65.4, 98.4]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[7, 137.201], [7, 137.201, 'c'], [6.8, 135.401, 'c'], [8.6, 136.201], [10.4, 137.001, 'c'], [104.601, 143.201, 'c'], [136.201, 167.201], [136.201, 167.201, 'c'], [91.001, 144.001, 'c'], [7, 137.201]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[17.4, 132.801], [17.4, 132.801, 'c'], [17.2, 131.001, 'c'], [19, 131.801], [20.8, 132.601, 'c'], [157.401, 131.601, 'c'], [181.001, 164.001], [181.001, 164.001, 'c'], [159.001, 138.801, 'c'], [17.4, 132.801]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[29, 128.801], [29, 128.801, 'c'], [28.8, 127.001, 'c'], [30.6, 127.801], [32.4, 128.601, 'c'], [205.801, 115.601, 'c'], [229.401, 148.001], [229.401, 148.001, 'c'], [219.801, 122.401, 'c'], [29, 128.801]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[39, 124.001], [39, 124.001, 'c'], [38.8, 122.201, 'c'], [40.6, 123.001], [42.4, 123.801, 'c'], [164.601, 85.2, 'c'], [188.201, 117.601], [188.201, 117.601, 'c'], [174.801, 93, 'c'], [39, 124.001]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-19, 146.801], [-19, 146.801, 'c'], [-19.2, 145.001, 'c'], [-17.4, 145.801], [-15.6, 146.601, 'c'], [2.2, 148.801, 'c'], [4.2, 187.601], [4.2, 187.601, 'c'], [-3, 145.601, 'c'], [-19, 146.801]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-27.8, 148.401], [-27.8, 148.401, 'c'], [-28, 146.601, 'c'], [-26.2, 147.401], [-24.4, 148.201, 'c'], [-10.2, 143.601, 'c'], [-13, 182.401], [-13, 182.401, 'c'], [-11.8, 147.201, 'c'], [-27.8, 148.401]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-35.8, 148.801], [-35.8, 148.801, 'c'], [-36, 147.001, 'c'], [-34.2, 147.801], [-32.4, 148.601, 'c'], [-17, 149.201, 'c'], [-29.4, 171.601], [-29.4, 171.601, 'c'], [-19.8, 147.601, 'c'], [-35.8, 148.801]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[11.526, 104.465], [11.526, 104.465, 'c'], [11.082, 106.464, 'c'], [12.631, 105.247], [28.699, 92.622, 'c'], [61.141, 33.72, 'c'], [116.826, 28.086], [116.826, 28.086, 'c'], [78.518, 15.976, 'c'], [11.526, 104.465]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[22.726, 102.665], [22.726, 102.665, 'c'], [21.363, 101.472, 'c'], [23.231, 100.847], [25.099, 100.222, 'c'], [137.541, 27.72, 'c'], [176.826, 35.686], [176.826, 35.686, 'c'], [149.719, 28.176, 'c'], [22.726, 102.665]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[1.885, 108.767], [1.885, 108.767, 'c'], [1.376, 110.366, 'c'], [3.087, 109.39], [12.062, 104.27, 'c'], [15.677, 47.059, 'c'], [59.254, 45.804], [59.254, 45.804, 'c'], [26.843, 31.09, 'c'], [1.885, 108.767]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-18.038, 119.793], [-18.038, 119.793, 'c'], [-19.115, 121.079, 'c'], [-17.162, 120.825], [-6.916, 119.493, 'c'], [14.489, 78.222, 'c'], [58.928, 83.301], [58.928, 83.301, 'c'], [26.962, 68.955, 'c'], [-18.038, 119.793]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-6.8, 113.667], [-6.8, 113.667, 'c'], [-7.611, 115.136, 'c'], [-5.742, 114.511], [4.057, 111.237, 'c'], [17.141, 66.625, 'c'], [61.729, 63.078], [61.729, 63.078, 'c'], [27.603, 55.135, 'c'], [-6.8, 113.667]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-25.078, 124.912], [-25.078, 124.912, 'c'], [-25.951, 125.954, 'c'], [-24.369, 125.748], [-16.07, 124.669, 'c'], [1.268, 91.24, 'c'], [37.264, 95.354], [37.264, 95.354, 'c'], [11.371, 83.734, 'c'], [-25.078, 124.912]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-32.677, 130.821], [-32.677, 130.821, 'c'], [-33.682, 131.866, 'c'], [-32.091, 131.748], [-27.923, 131.439, 'c'], [2.715, 98.36, 'c'], [21.183, 113.862], [21.183, 113.862, 'c'], [9.168, 95.139, 'c'], [-32.677, 130.821]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[36.855, 98.898], [36.855, 98.898, 'c'], [35.654, 97.543, 'c'], [37.586, 97.158], [39.518, 96.774, 'c'], [160.221, 39.061, 'c'], [198.184, 51.927], [198.184, 51.927, 'c'], [172.243, 41.053, 'c'], [36.855, 98.898]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[3.4, 163.201], [3.4, 163.201, 'c'], [3.2, 161.401, 'c'], [5, 162.201], [6.8, 163.001, 'c'], [22.2, 163.601, 'c'], [9.8, 186.001], [9.8, 186.001, 'c'], [19.4, 162.001, 'c'], [3.4, 163.201]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[13.8, 161.601], [13.8, 161.601, 'c'], [13.6, 159.801, 'c'], [15.4, 160.601], [17.2, 161.401, 'c'], [35, 163.601, 'c'], [37, 202.401], [37, 202.401, 'c'], [29.8, 160.401, 'c'], [13.8, 161.601]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[20.6, 160.001], [20.6, 160.001, 'c'], [20.4, 158.201, 'c'], [22.2, 159.001], [24, 159.801, 'c'], [48.6, 163.201, 'c'], [72.2, 195.601], [72.2, 195.601, 'c'], [36.6, 158.801, 'c'], [20.6, 160.001]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[28.225, 157.972], [28.225, 157.972, 'c'], [27.788, 156.214, 'c'], [29.678, 156.768], [31.568, 157.322, 'c'], [52.002, 155.423, 'c'], [90.099, 189.599], [90.099, 189.599, 'c'], [43.924, 154.656, 'c'], [28.225, 157.972]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[38.625, 153.572], [38.625, 153.572, 'c'], [38.188, 151.814, 'c'], [40.078, 152.368], [41.968, 152.922, 'c'], [76.802, 157.423, 'c'], [128.499, 192.399], [128.499, 192.399, 'c'], [54.324, 150.256, 'c'], [38.625, 153.572]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-1.8, 142.001], [-1.8, 142.001, 'c'], [-2, 140.201, 'c'], [-0.2, 141.001], [1.6, 141.801, 'c'], [55, 144.401, 'c'], [85.4, 171.201], [85.4, 171.201, 'c'], [50.499, 146.426, 'c'], [-1.8, 142.001]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-11.8, 146.001], [-11.8, 146.001, 'c'], [-12, 144.201, 'c'], [-10.2, 145.001], [-8.4, 145.801, 'c'], [16.2, 149.201, 'c'], [39.8, 181.601], [39.8, 181.601, 'c'], [4.2, 144.801, 'c'], [-11.8, 146.001]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[49.503, 148.962], [49.503, 148.962, 'c'], [48.938, 147.241, 'c'], [50.864, 147.655], [52.79, 148.068, 'c'], [87.86, 150.004, 'c'], [141.981, 181.098], [141.981, 181.098, 'c'], [64.317, 146.704, 'c'], [49.503, 148.962]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[57.903, 146.562], [57.903, 146.562, 'c'], [57.338, 144.841, 'c'], [59.264, 145.255], [61.19, 145.668, 'c'], [96.26, 147.604, 'c'], [150.381, 178.698], [150.381, 178.698, 'c'], [73.317, 143.904, 'c'], [57.903, 146.562]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[67.503, 141.562], [67.503, 141.562, 'c'], [66.938, 139.841, 'c'], [68.864, 140.255], [70.79, 140.668, 'c'], [113.86, 145.004, 'c'], [203.582, 179.298], [203.582, 179.298, 'c'], [82.917, 138.904, 'c'], [67.503, 141.562]], -closed => 1, -linecolor => "#000000", -fillcolor => "#ffffff", -filled => 1, -linewidth => 0.1); - -$zinc->add('curve',$top_group,[[-43.8, 148.401], [-43.8, 148.401, 'c'], [-38.6, 148.001, 'c'], [-39.8, 149.601], [-41, 151.201, 'c'], [-43.4, 150.401, 'c'], [-43.4, 150.401], [-43.8, 148.401]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-13, 162.401], [-13, 162.401, 'c'], [-7.8, 162.001, 'c'], [-9, 163.601], [-10.2, 165.201, 'c'], [-12.6, 164.401, 'c'], [-12.6, 164.401], [-13, 162.401]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-21.8, 162.001], [-21.8, 162.001, 'c'], [-16.6, 161.601, 'c'], [-17.8, 163.201], [-19, 164.801, 'c'], [-21.4, 164.001, 'c'], [-21.4, 164.001], [-21.8, 162.001]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-117.169, 150.182], [-117.169, 150.182, 'c'], [-112.124, 151.505, 'c'], [-113.782, 152.624], [-115.439, 153.744, 'c'], [-117.446, 152.202, 'c'], [-117.446, 152.202], [-117.169, 150.182]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-115.169, 140.582], [-115.169, 140.582, 'c'], [-110.124, 141.905, 'c'], [-111.782, 143.024], [-113.439, 144.144, 'c'], [-115.446, 142.602, 'c'], [-115.446, 142.602], [-115.169, 140.582]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-122.369, 136.182], [-122.369, 136.182, 'c'], [-117.324, 137.505, 'c'], [-118.982, 138.624], [-120.639, 139.744, 'c'], [-122.646, 138.202, 'c'], [-122.646, 138.202], [-122.369, 136.182]], -closed => 1, -fillcolor => "#000000", -filled => 1, -linecolor => "#000000"); - -$zinc->add('curve',$top_group,[[-42.6, 211.201], [-42.6, 211.201, 'c'], [-44.2, 211.201, 'c'], [-48.2, 213.201], [-50.2, 213.201, 'c'], [-61.4, 216.801, 'c'], [-67, 226.801], [-67, 226.801, 'c'], [-54.6, 217.201, 'c'], [-42.6, 211.201]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[45.116, 303.847], [45.257, 304.105, 'c'], [45.312, 304.525, 'c'], [45.604, 304.542], [46.262, 304.582, 'c'], [47.495, 304.883, 'c'], [47.37, 304.247], [46.522, 299.941, 'c'], [45.648, 295.004, 'c'], [41.515, 293.197], [40.876, 292.918, 'c'], [39.434, 293.331, 'c'], [39.36, 294.215], [39.233, 295.739, 'c'], [39.116, 297.088, 'c'], [39.425, 298.554], [39.725, 299.975, 'c'], [41.883, 299.985, 'c'], [42.8, 298.601], [43.736, 300.273, 'c'], [44.168, 302.116, 'c'], [45.116, 303.847]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[34.038, 308.581], [34.786, 309.994, 'c'], [34.659, 311.853, 'c'], [36.074, 312.416], [36.814, 312.71, 'c'], [38.664, 311.735, 'c'], [38.246, 310.661], [37.444, 308.6, 'c'], [37.056, 306.361, 'c'], [35.667, 304.55], [35.467, 304.288, 'c'], [35.707, 303.755, 'c'], [35.547, 303.427], [34.953, 302.207, 'c'], [33.808, 301.472, 'c'], [32.4, 301.801], [31.285, 304.004, 'c'], [32.433, 306.133, 'c'], [33.955, 307.842], [34.091, 307.994, 'c'], [33.925, 308.37, 'c'], [34.038, 308.581]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-5.564, 303.391], [-5.672, 303.014, 'c'], [-5.71, 302.551, 'c'], [-5.545, 302.23], [-5.014, 301.197, 'c'], [-4.221, 300.075, 'c'], [-4.558, 299.053], [-4.906, 297.997, 'c'], [-6.022, 298.179, 'c'], [-6.672, 298.748], [-7.807, 299.742, 'c'], [-7.856, 301.568, 'c'], [-8.547, 302.927], [-8.743, 303.313, 'c'], [-8.692, 303.886, 'c'], [-9.133, 304.277], [-9.607, 304.698, 'c'], [-10.047, 306.222, 'c'], [-9.951, 306.793], [-9.898, 307.106, 'c'], [-10.081, 317.014, 'c'], [-9.859, 316.751], [-9.24, 316.018, 'c'], [-6.19, 306.284, 'c'], [-6.121, 305.392], [-6.064, 304.661, 'c'], [-5.332, 304.196, 'c'], [-5.564, 303.391]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-31.202, 296.599], [-28.568, 294.1, 'c'], [-25.778, 291.139, 'c'], [-26.22, 287.427], [-26.336, 286.451, 'c'], [-28.111, 286.978, 'c'], [-28.298, 287.824], [-29.1, 291.449, 'c'], [-31.139, 294.11, 'c'], [-33.707, 296.502], [-35.903, 298.549, 'c'], [-37.765, 304.893, 'c'], [-38, 305.401], [-34.303, 300.145, 'c'], [-32.046, 297.399, 'c'], [-31.202, 296.599]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-44.776, 290.635], [-44.253, 290.265, 'c'], [-44.555, 289.774, 'c'], [-44.338, 289.442], [-43.385, 287.984, 'c'], [-42.084, 286.738, 'c'], [-42.066, 285], [-42.063, 284.723, 'c'], [-42.441, 284.414, 'c'], [-42.776, 284.638], [-43.053, 284.822, 'c'], [-43.395, 284.952, 'c'], [-43.503, 285.082], [-45.533, 287.531, 'c'], [-46.933, 290.202, 'c'], [-48.376, 293.014], [-48.559, 293.371, 'c'], [-49.703, 297.862, 'c'], [-49.39, 297.973], [-49.151, 298.058, 'c'], [-47.431, 293.877, 'c'], [-47.221, 293.763], [-45.958, 293.077, 'c'], [-45.946, 291.462, 'c'], [-44.776, 290.635]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-28.043, 310.179], [-27.599, 309.31, 'c'], [-26.023, 308.108, 'c'], [-26.136, 307.219], [-26.254, 306.291, 'c'], [-25.786, 304.848, 'c'], [-26.698, 305.536], [-27.955, 306.484, 'c'], [-31.404, 307.833, 'c'], [-31.674, 313.641], [-31.7, 314.212, 'c'], [-28.726, 311.519, 'c'], [-28.043, 310.179]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-13.6, 293.001], [-13.2, 292.333, 'c'], [-12.492, 292.806, 'c'], [-12.033, 292.543], [-11.385, 292.171, 'c'], [-10.774, 291.613, 'c'], [-10.482, 290.964], [-9.512, 288.815, 'c'], [-7.743, 286.995, 'c'], [-7.6, 284.601], [-9.091, 283.196, 'c'], [-9.77, 285.236, 'c'], [-10.4, 286.201], [-11.723, 284.554, 'c'], [-12.722, 286.428, 'c'], [-14.022, 286.947], [-14.092, 286.975, 'c'], [-14.305, 286.628, 'c'], [-14.38, 286.655], [-15.557, 287.095, 'c'], [-16.237, 288.176, 'c'], [-17.235, 288.957], [-17.406, 289.091, 'c'], [-17.811, 288.911, 'c'], [-17.958, 289.047], [-18.61, 289.65, 'c'], [-19.583, 289.975, 'c'], [-19.863, 290.657], [-20.973, 293.364, 'c'], [-24.113, 295.459, 'c'], [-26, 303.001], [-25.619, 303.91, 'c'], [-21.488, 296.359, 'c'], [-21.001, 295.661], [-20.165, 294.465, 'c'], [-20.047, 297.322, 'c'], [-18.771, 296.656], [-18.72, 296.629, 'c'], [-18.534, 296.867, 'c'], [-18.4, 297.001], [-18.206, 296.721, 'c'], [-17.988, 296.492, 'c'], [-17.6, 296.601], [-17.6, 296.201, 'c'], [-17.734, 295.645, 'c'], [-17.533, 295.486], [-16.296, 294.509, 'c'], [-16.38, 293.441, 'c'], [-15.6, 292.201], [-15.142, 292.99, 'c'], [-14.081, 292.271, 'c'], [-13.6, 293.001]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[46.2, 347.401], [46.2, 347.401, 'c'], [53.6, 327.001, 'c'], [49.2, 315.801], [49.2, 315.801, 'c'], [60.6, 337.401, 'c'], [56, 348.601], [56, 348.601, 'c'], [55.6, 338.201, 'c'], [51.6, 333.201], [51.6, 333.201, 'c'], [47.6, 346.001, 'c'], [46.2, 347.401]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[31.4, 344.801], [31.4, 344.801, 'c'], [36.8, 336.001, 'c'], [28.8, 317.601], [28.8, 317.601, 'c'], [28, 338.001, 'c'], [21.2, 349.001], [21.2, 349.001, 'c'], [35.4, 328.801, 'c'], [31.4, 344.801]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[21.4, 342.801], [21.4, 342.801, 'c'], [21.2, 322.801, 'c'], [21.6, 319.801], [21.6, 319.801, 'c'], [17.8, 336.401, 'c'], [7.6, 346.001], [7.6, 346.001, 'c'], [22, 334.001, 'c'], [21.4, 342.801]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[11.8, 310.801], [11.8, 310.801, 'c'], [17.8, 324.401, 'c'], [7.8, 342.801], [7.8, 342.801, 'c'], [14.2, 330.601, 'c'], [9.4, 323.601], [9.4, 323.601, 'c'], [12, 320.201, 'c'], [11.8, 310.801]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-7.4, 342.401], [-7.4, 342.401, 'c'], [-8.4, 326.801, 'c'], [-6.6, 324.601], [-6.6, 324.601, 'c'], [-6.4, 318.201, 'c'], [-6.8, 317.201], [-6.8, 317.201, 'c'], [-2.8, 311.001, 'c'], [-2.6, 318.401], [-2.6, 318.401, 'c'], [-1.2, 326.201, 'c'], [1.6, 330.801], [1.6, 330.801, 'c'], [5.2, 336.201, 'c'], [5, 342.601], [5, 342.601, 'c'], [-5, 312.401, 'c'], [-7.4, 342.401]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-11, 314.801], [-11, 314.801, 'c'], [-17.6, 325.601, 'c'], [-19.4, 344.601], [-19.4, 344.601, 'c'], [-20.8, 338.401, 'c'], [-17, 324.001], [-17, 324.001, 'c'], [-12.8, 308.601, 'c'], [-11, 314.801]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-32.8, 334.601], [-32.8, 334.601, 'c'], [-27.8, 329.201, 'c'], [-26.4, 324.201], [-26.4, 324.201, 'c'], [-22.8, 308.401, 'c'], [-29.2, 317.001], [-29.2, 317.001, 'c'], [-29, 325.001, 'c'], [-37.2, 332.401], [-37.2, 332.401, 'c'], [-32.4, 330.001, 'c'], [-32.8, 334.601]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-38.6, 329.601], [-38.6, 329.601, 'c'], [-35.2, 312.201, 'c'], [-34.4, 311.401], [-34.4, 311.401, 'c'], [-32.6, 308.001, 'c'], [-35.4, 311.201], [-35.4, 311.201, 'c'], [-44.2, 330.401, 'c'], [-48.2, 337.001], [-48.2, 337.001, 'c'], [-40.2, 327.801, 'c'], [-38.6, 329.601]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-44.4, 313.001], [-44.4, 313.001, 'c'], [-32.8, 290.601, 'c'], [-54.6, 316.401], [-54.6, 316.401, 'c'], [-43.6, 306.601, 'c'], [-44.4, 313.001]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[-59.8, 298.401], [-59.8, 298.401, 'c'], [-55, 279.601, 'c'], [-52.4, 279.801], [-52.4, 279.801, 'c'], [-44.2, 270.801, 'c'], [-50.8, 281.401], [-50.8, 281.401, 'c'], [-56.8, 291.001, 'c'], [-56.2, 300.801], [-56.2, 300.801, 'c'], [-56.8, 291.201, 'c'], [-59.8, 298.401]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[270.5, 287], [270.5, 287, 'c'], [258.5, 277, 'c'], [256, 273.5], [256, 273.5, 'c'], [269.5, 292, 'c'], [269.5, 299], [269.5, 299, 'c'], [272, 291.5, 'c'], [270.5, 287]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[276, 265], [276, 265, 'c'], [255, 250, 'c'], [251.5, 242.5], [251.5, 242.5, 'c'], [278, 272, 'c'], [278, 276.5], [278, 276.5, 'c'], [278.5, 267.5, 'c'], [276, 265]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[293, 111], [293, 111, 'c'], [281, 103, 'c'], [279.5, 105], [279.5, 105, 'c'], [290, 111.5, 'c'], [292.5, 120], [292.5, 120, 'c'], [291, 111, 'c'], [293, 111]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - -$zinc->add('curve',$top_group,[[301.5, 191.5], [284, 179.5], [284, 179.5, 'c'], [303, 196.5, 'c'], [303.5, 200.5], [301.5, 191.5]], -closed => 1, -fillcolor => "#cccccc", -filled => 1, -linecolor => "#cccccc"); - - - -### translating ojects for making them all visibles -$zinc->translate($top_group, 200, 150); - - -### on ajoute quelques binding bien pratiques pour la mise au point - -my $i=0; - -$zinc->Tk::bind('', [\&press, \&motion]); -$zinc->Tk::bind('', [\&release]); -$zinc->Tk::bind('', [\&press, \&zoom]); -$zinc->Tk::bind('', [\&release]); -$zinc->Tk::bind('', [\&press, \&rotate]); -$zinc->Tk::bind('', [\&release]); - - -&Tk::MainLoop; - - -##### bindings for moving, rotating, scaling the items -my ($cur_x, $cur_y, $cur_angle); -sub press { - my ($zinc, $action) = @_; - my $ev = $zinc->XEvent(); - $cur_x = $ev->x; - $cur_y = $ev->y; - $cur_angle = atan2($cur_y, $cur_x); - $zinc->Tk::bind('', [$action]); -} - -sub motion { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my @res = $zinc->transform($top_group, [$lx, $ly, $cur_x, $cur_y]); - $zinc->translate($top_group, $res[0] - $res[2], $res[1] - $res[3]); - $cur_x = $lx; - $cur_y = $ly; - $i++; -} - -sub zoom { - my ($zinc, $self) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my $maxx; - my $maxy; - my $sx; - my $sy; - - if ($lx > $cur_x) { - $maxx = $lx; - } else { - $maxx = $cur_x; - } - if ($ly > $cur_y) { - $maxy = $ly - } else { - $maxy = $cur_y; - } - return if ($maxx == 0 || $maxy == 0); - $sx = 1.0 + ($lx - $cur_x)/$maxx; - $sy = 1.0 + ($ly - $cur_y)/$maxy; - $cur_x = $lx; - $cur_y = $ly; - $zinc->scale($top_group, $sx, $sx); #$sy); -} - -sub rotate { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my $langle; - - $langle = atan2($ly, $lx); - $zinc->rotate($top_group, -($langle - $cur_angle)); - $cur_angle = $langle; -} - -sub release { - my ($zinc) = @_; - $zinc->Tk::bind('', ''); -} diff --git a/Perl/demos/Tk/demos/zinc_lib/tkZincLogo.pl b/Perl/demos/Tk/demos/zinc_lib/tkZincLogo.pl deleted file mode 100644 index 8e3ca9d..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/tkZincLogo.pl +++ /dev/null @@ -1,165 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# this simple demo has been adapted by C. Mertz from the original -# work of JL. Vinot - -package tkZincLogo; # for avoiding symbol collision between different demos - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; -use Tk::Zinc::Logo; # this module implements a class which instances are Zinc logo! - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-140-*-*-*-*-*-*'; -my $mw = MainWindow->new(); -my $text = $mw->Scrolled(qw/Text -relief sunken -borderwidth 2 -setgrid true - -height 7 -scrollbars ''/); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', - 'This tkZinc logo should used openGL for a correct rendering! - You can transform this logo with your mouse: - Drag-Button 1 for moving the logo, - Drag-Button 2 for zooming the logo, - Drag-Button 3 for rotating the logo, - Shift-Drag-Button 1 for modifying the logo transparency, - Shift-Drag-Button 2 for modifying the logo gradient.' - ); - -my $zinc = $mw->Zinc(-width => 350, -height => 250, - -render => 1, - -font => "10x20", # usually fonts are sets in resources - # but for this example it is set in the code! - -borderwidth => 3, -relief => 'sunken', - )->pack; - -my $group = $zinc->add('group', 1, ); - - -my $logo = Tk::Zinc::Logo->new(-widget => $zinc, - -parent => $group, - -position => [40, 70], - -priority => 800, - -scale => [.6, .6], - ); - - -$zinc->Tk::bind('', [\&press, \&motion]); -$zinc->Tk::bind('', [\&release]); - -$zinc->Tk::bind('', [\&press, \&zoom]); -$zinc->Tk::bind('', [\&release]); - -$zinc->Tk::bind('', [\&press, \&rotate]); -$zinc->Tk::bind('', [\&release]); - - -$zinc->Tk::bind('', [\&press, \&modifyAlpha]); -$zinc->Tk::bind('', [\&release]); - -$zinc->Tk::bind('', [\&press, \&modifyGradient]); -$zinc->Tk::bind('', [\&release]); - - -# -# Controls for the window transform. -# -my ($cur_x, $cur_y, $cur_angle); -sub press { - my ($zinc, $action) = @_; - my $ev = $zinc->XEvent(); - $cur_x = $ev->x; - $cur_y = $ev->y; - $cur_angle = atan2($cur_y, $cur_x); - $zinc->Tk::bind('', [$action]); -} - -sub modifyAlpha { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $xrate = $lx / $zinc->cget(-width); - - $xrate = 0 if $xrate < 0; - $xrate = 1 if $xrate > 1; - - my $alpha = $xrate * 100; - $zinc->itemconfigure($group, -alpha => $alpha); -} - -sub modifyGradient { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - my $ly = $ev->y; - my $yrate = $ly / $zinc->cget(-height); - - $yrate = 0 if $yrate < 0; - $yrate = 1 if $yrate > 1; - my $gradientpercent = sprintf ("%d", $yrate * 100); - - $zinc->itemconfigure ('zinc_shape', -fillcolor => "=axial 270|#ffffff 0 28|#66848c $gradientpercent|#7192aa"); -} - - -sub motion { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my @res; - - @res = $zinc->transform($group, [$lx, $ly, $cur_x, $cur_y]); - $zinc->translate($group, $res[0] - $res[2], $res[1] - $res[3]); - $cur_x = $lx; - $cur_y = $ly; -} - -sub zoom { - my ($zinc, $self) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my $maxx; - my $maxy; - my $sx; - my $sy; - - if ($lx > $cur_x) { - $maxx = $lx; - } else { - $maxx = $cur_x; - } - if ($ly > $cur_y) { - $maxy = $ly - } else { - $maxy = $cur_y; - } - return if ($maxx == 0 || $maxy == 0); - $sx = 1.0 + ($lx - $cur_x)/$maxx; - $sy = 1.0 + ($ly - $cur_y)/$maxy; - $cur_x = $lx; - $cur_y = $ly; - $zinc->scale($group, $sx, $sy); -} - -sub rotate { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my $langle; - - $langle = atan2($ly, $lx); - $zinc->rotate($group, -($langle - $cur_angle)); - $cur_angle = $langle; -} - -sub release { - my ($zinc) = @_; - $zinc->Tk::bind('', ''); -} - -Tk::MainLoop; diff --git a/Perl/demos/Tk/demos/zinc_lib/transforms.pl b/Perl/demos/Tk/demos/zinc_lib/transforms.pl deleted file mode 100644 index 0d8cab0..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/transforms.pl +++ /dev/null @@ -1,568 +0,0 @@ -#!/usr/bin/perl -w - -# $Id$ -# This simple demo has been developped by P. Lecoanet - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -# -# TODO: -# -# Ajouter la construction des items manquants -# - -use Tk; -use Tk::Zinc; - -my $currentgroup; -my $currentitem; -my $mw = MainWindow->new(); -my $top = 1; - -my $inactiveAxisColor = 'black'; -my $activeAxisColor = 'red'; -my $worldAxisColor = '#a5a5a5'; - -my $itemtype; -my $composerot = 1; -my $composescale = 1; -my $drag = 0; - -my $logo = $mw->Photo(-file => Tk->findINC('demos/zinc_data/zinc_anti.gif')); - -my $text = $mw->Text(-relief => 'sunken', - -borderwidth => 2, - -height => 12); -$text->pack(-expand => 0, -fill => 'x'); -$text->insert('0.0', 'Items are always added to the current group. -The available commands are: - Button 1 on the background, add an item with initial translation - Button 2 on the background, add a group with initial translation - Button 1 on item/group axes, select/deselect that item space - Drag Button 1 on item/group axes, translate that item space - Del reset the transformation - Shift-Del reset a group direct children transformations - PageUp/Down scale up/down - End/Home rotate right/left - Ins swap the Y axis - 4 arrows translate in the 4 directions'); -$text->configure(-state => 'disabled'); - -my $zinc = $mw->Zinc(-borderwidth => 3, - -highlightthickness => 0, - -relief => 'sunken', - -render => 0, - -takefocus => 1); -$zinc->pack(-expand => 1, -fill => 'both'); -$zinc->configure(-width => 500, -height => 500); - -my $rc = $mw->Frame()->pack(-expand => 0, -fill => 'x'); -my $option = $rc->Optionmenu(-options => ['rectangle', 'arc', - 'curve', - 'icon', 'tabular', - 'text', 'track', - 'triangles', 'waypoint'], -# -command => sub { $zinc->Tk::focus(); }, - -variable => \$itemtype)->grid(-row => 0, - -column => 1, - -sticky => 'w'); - -$rc->Button(-text => 'Add item', - -command => \&additem)->grid(-row => 0, - -column => 2, - -padx => 10, - -sticky => 'ew'); -$rc->Button(-text => 'Add group', - -command => \&addgroup)->grid(-row => 0, - -column => 3, - -padx => 10, - -sticky => 'ew'); -$rc->Button(-text => 'Remove', - -command => \&removeitem)->grid(-row => 0, - -column => 4, - -padx => 10, - -sticky => 'ew'); - -$rc->Checkbutton(-text => '-composescale', - -command => \&togglecomposescale, - -variable => \$composescale)->grid(-row => 0, - -column => 6, - -sticky => 'w'); - -$rc->Checkbutton(-text => '-composesrotation', - -command => \&togglecomposerot, - -variable => \$composerot)->grid(-row => 1, - -column => 6, - -sticky => 'w'); - - -my $world = $zinc->add('group', $top); -$zinc->add('curve', $top, [0, 0, 80, 0], - -linewidth => 3, - -linecolor => $worldAxisColor, - -lastend => [6,8,3], - -tags => ["axis:$world"]); -$zinc->add('curve', $top, [0, 0, 0, 80], - -linewidth => 3, - -linecolor => $worldAxisColor, - -lastend => [6,8,3], - -tags => ["axis:$world"]); -$zinc->add('rectangle', $top, [-2, -2, 2, 2], - -filled => 1, - -fillcolor => $worldAxisColor, - -linecolor => $worldAxisColor, - -linewidth => 3, - -tags => ["axis:$world"]); -$zinc->add('text', $top, - -text => "This is the origin\nof the world", - -anchor => 's', - -color => $worldAxisColor, - -alignment => 'center', - -tags => ["axis:$world", 'text']); - - -$currentgroup = $world; - -$zinc->Tk::bind('<1>', [\&mouseadd, 'item']); -$zinc->Tk::bind('<2>', [\&mouseadd, 'group']); -$zinc->Tk::bind('', \&moveup); -$zinc->Tk::bind('', \&moveleft); -$zinc->Tk::bind('', \&moveright); -$zinc->Tk::bind('', \&movedown); -$zinc->Tk::bind('', \&scaledown); -$zinc->Tk::bind('', \&scaleup); -$zinc->Tk::bind('', \&reset); -$zinc->Tk::bind('', \&resetchildren); -$zinc->Tk::bind('', \&rotateleft); -$zinc->Tk::bind('', \&rotateright); -$zinc->Tk::bind('', \&swapaxis); - -$zinc->Tk::bind('', [\&resize]); - -$zinc->Tk::focus(); -$zinc->focusFollowsMouse(); - - -MainLoop(); - -sub resize { - my $ev = $zinc->XEvent(); - my $x = $ev->w/2; - my $y = $ev->h/2; - - $zinc->treset($world); - $zinc->treset("axis:$world"); - $zinc->translate($world, $x, $y); - $zinc->translate("axis:$world", $x, $y); -} - -sub swapaxis { - if (defined($currentitem)) { - $zinc->scale($currentitem, 1, -1); - $zinc->scale("axisgrp:$currentitem", 1, -1); - } -} - -sub togglecomposerot { - if (defined($currentitem)) { - $zinc->itemconfigure($currentitem, -composerotation => $composerot); - $zinc->itemconfigure("axisgrp:$currentitem", -composerotation => $composerot); - } -} - -sub togglecomposescale { - my $bool; - - if (defined($currentitem)) { - $zinc->itemconfigure($currentitem, -composescale => $composescale); - $zinc->itemconfigure("axisgrp:$currentitem", -composescale => $composescale); - } -} - -sub dragitem { - $drag = 1; - return if (!defined($currentitem)); - - my $ev = $zinc->XEvent(); - my $group = $zinc->group($currentitem); - my ($x, $y) = $zinc->transform($group, [$ev->x, $ev->y]); - - $zinc->treset($currentitem); - $zinc->treset("axisgrp:$currentitem"); - $zinc->translate($currentitem, $x, $y); - $zinc->translate("axisgrp:$currentitem", $x, $y); -} - -sub select { - my @tags = $zinc->gettags('current'); - my $t; - foreach $t (@tags) { - if ($t =~ '^axis:(\d+)') { - changeitem($1); - } - } -} - -sub changeitem { - my ($item) = @_; - - if (defined($currentitem) && !$drag) { - $zinc->itemconfigure("axis:$currentitem && !text", - -linecolor => $inactiveAxisColor, - -fillcolor => $inactiveAxisColor); - if ($currentitem != $currentgroup) { - $zinc->itemconfigure("axis:$currentitem && !text", - -linewidth => 1); - } - } - if (!defined($currentitem) || ($item != $currentitem)) { - $zinc->itemconfigure("axis:$item && !text", - -linecolor => $activeAxisColor, - -fillcolor => $activeAxisColor, - -linewidth => 3); - $currentitem = $item; - $composerot = $zinc->itemcget($currentitem, -composerotation); - $zinc->itemconfigure("axisgrp:$currentitem", -composerotation => $composerot); - $composescale = $zinc->itemcget($currentitem, -composescale); - $zinc->itemconfigure("axisgrp:$currentitem", -composescale => $composescale); - } - elsif (!$drag) { - $currentitem = undef; - $composerot = $composescale = 1; - } - $drag = 0; -} - -sub selectgroup { - my @tags = $zinc->gettags('current'); - my $t; - foreach $t (@tags) { - if ($t =~ '^axis:(\d+)') { - changegroup($1); - } - } -} - -sub changegroup { - my ($grp) = @_; - - changeitem($grp); - $zinc->itemconfigure("axis:$currentgroup && !text", - -linewidth => 1); - if (defined($currentitem)) { - $currentgroup = $currentitem; - } - else { - $currentgroup = $world; - } - - $zinc->itemconfigure("axis:$currentgroup && !text", - -linewidth => 3); -} - -sub reset { - if (defined($currentitem)) { - $zinc->treset($currentitem); - $zinc->treset("axisgrp:$currentitem"); - } -} - -sub resetchildren { - my @children; - - if (defined($currentitem) && ($zinc->type($currentitem) eq 'group')) { - @children = $zinc->addtag('rt', 'withtag', 'all', $currentitem, 0); - $zinc->treset('rt'); - $zinc->dtag('rt', 'rt'); - } -} - -sub moveup { - move(0, 20); -} - -sub movedown { - move(0, -20); -} - -sub moveright { - move(20, 0); -} - -sub moveleft { - move(-20, 0); -} - -sub move { - my ($dx, $dy) = @_; - - if (defined($currentitem)) { - $zinc->translate($currentitem, $dx, $dy); - $zinc->translate("axisgrp:$currentitem", $dx, $dy); - } -} - -sub scaleup { - scale(1.1, 1.1); -} - -sub scaledown { - scale(0.9, 0.9); -} - -sub scale { - my ($dx, $dy) = @_; - - if (defined($currentitem)) { - $zinc->scale($currentitem, $dx, $dy); - $zinc->scale("axisgrp:$currentitem", $dx, $dy); - } -} - -sub rotateleft { - rotate(-3.14159/18); -} - -sub rotateright { - rotate(3.14159/18); -} - -sub rotate { - my ($angle) = @_; - - if (defined($currentitem)) { - $zinc->rotate($currentitem, $angle); - $zinc->rotate("axisgrp:$currentitem", $angle); - } -} - -sub newrect { - return $zinc->add('rectangle', $currentgroup, - [-15, -15, 15, 15], - -filled => 1, - -linewidth => 0, - -fillcolor => 'tan'); -} - -sub newarc { - return $zinc->add('arc', $currentgroup, - [-25, -15, 25, 15], - -filled => 1, - -linewidth => 0, - -fillcolor => 'tan'); -} - -sub newcurve { - return $zinc->add('curve', $currentgroup, - [-15, -15, -15, 15, 15, 15, 15, -15], - -filled => 1, - -linewidth => 0, - -fillcolor => 'tan'); -} - -sub newtext { - my $item = $zinc->add('text', $currentgroup, - -anchor => 's'); - $zinc->itemconfigure($item, -text => "Item id: $item"); - return $item; -} - -sub newicon { - my $item = $zinc->add('icon', $currentgroup, - -image => $logo, - -anchor => 'center'); - - return $item; -} - -sub newtriangles { - my $item = $zinc->add('triangles', $currentgroup, - [-25, 15, -10, -15, 5, 15, - 20, -15, 35, 15, 50, -30], - -colors => ['tan', 'wheat', 'tan', 'wheat']); - return $item; -} - -sub newtrack { - my $labelformat = "x80x50+0+0 a0a0^0^0 a0a0^0>1 a0a0>2>1 x30a0>3>1 a0a0^0>2"; - - my $item=$zinc->add('track', $currentgroup, 6, - -labelformat => $labelformat, - -speedvector => [30, -15], - -markersize => 20); - $zinc->itemconfigure($item, 0, - -filled => 0, - -bordercolor => 'DarkGreen', - -border => 'contour'); - $zinc->itemconfigure($item, 1, - -filled => 1, - -backcolor => 'gray60', - -text => 'AFR6128'); - $zinc->itemconfigure($item, 2, - -filled => 0, - -backcolor => 'gray65', - -text => '390'); - $zinc->itemconfigure($item, 3, - -filled => 0, - -backcolor => 'gray65', - -text => '/'); - $zinc->itemconfigure($item, 4, - -filled => 0, - -backcolor => 'gray65', - -text => '350'); - $zinc->itemconfigure($item, 5, - -filled => 0, - -backcolor => 'gray65', - -text => 'TUR'); - return $item; -} - -sub newwaypoint { - my $labelformat = "a0a0+0+0 a0a0>0^1"; - - my $item=$zinc->add('waypoint', $currentgroup, 2, - -labelformat => $labelformat); - $zinc->itemconfigure($item, 0, - -filled => 1, - -backcolor => 'DarkGreen', - -text => 'TUR'); - $zinc->itemconfigure($item, 1, - -text => '>>>'); - return $item; -} - -sub newtabular { - my $labelformat = "f700f600+0+0 f700a0^0^0 f700a0^0>1 f700a0^0>2 f700a0^0>3 f700a0^0>4 f700a0^0>5"; - - my $item=$zinc->add('tabular', $currentgroup, 7, - -labelformat => $labelformat); - $zinc->itemconfigure($item, 0, - -filled => 1, - -border => 'contour', - -bordercolor => 'black', - -backcolor => 'gray60'); - $zinc->itemconfigure($item, 1, - -alignment => 'center', - -text => 'AFR6128'); - $zinc->itemconfigure($item, 2, - -alignment => 'center', - -text => '390'); - $zinc->itemconfigure($item, 3, - -alignment => 'center', - -text => '370'); - $zinc->itemconfigure($item, 4, - -alignment => 'center', - -text => '350'); - $zinc->itemconfigure($item, 5, - -alignment => 'center', - -text => '330'); - $zinc->itemconfigure($item, 6, - -alignment => 'center', - -text => 'TUR'); - return $item; -} - -sub addaxes { - my ($item, $length, $command, $infront) = @_; - - my $axesgroup = $zinc->add('group', $currentgroup, - -tags => ["axisgrp:$item"]); - $zinc->add('curve', $axesgroup, [0, 0, $length, 0], - -linewidth => 2, - -lastend => [6,8,3], - -tags => ["axis:$item"]); - $zinc->add('curve', $axesgroup, [0, 0, 0, $length], - -linewidth => 2, - -lastend => [6,8,3], - -tags => ["axis:$item"]); - $zinc->add('rectangle', $axesgroup, [-2, -2, 2, 2], - -filled => 1, - -linewidth => 0, - -composescale => 0, - -tags => ["axis:$item"]); - if ($infront) { - $zinc->raise($item, $axesgroup); - } - $zinc->bind("axis:$item", '', \&dragitem); - $zinc->bind("axis:$item", '', $command); -} - -sub additem { - my $item; - my $length = 25; - my $itemontop = 0; - - if ($itemtype eq 'rectangle') { - $item = newrect(); - } - elsif ($itemtype eq 'arc') { - $item = newarc(); - } - elsif ($itemtype eq 'curve') { - $item = newcurve(); - } - elsif ($itemtype eq 'triangles') { - $item = newtriangles(); - } - elsif ($itemtype eq 'icon') { - $item = newicon(); - } - elsif ($itemtype eq 'text') { - $item = newtext(); - } - elsif ($itemtype eq 'track') { - $item = newtrack(); - $itemontop = 1; - } - elsif ($itemtype eq 'waypoint') { - $item = newwaypoint(); - $itemontop = 1; - } - elsif ($itemtype eq 'tabular') { - $item = newtabular(); - } - - addaxes($item, 25, \&select, $itemontop); - changeitem($item); -} - -sub addgroup { - my $item = $zinc->add('group', $currentgroup); - - addaxes($item, 80, \&selectgroup, 1); - changegroup($item); -} - -sub mouseadd { - my ($w, $itemorgrp) = @_; - my $ev = $zinc->XEvent(); - my ($x, $y) = $zinc->transform($currentgroup, [$ev->x, $ev->y]); - my $item = $zinc->find('withtag', 'current'); - - if (defined($item)) { - my @tags = $zinc->gettags($item); - foreach my $t (@tags) { - return if ($t =~ '^axis'); - } - } - if ($itemorgrp eq 'group') { - addgroup(); - } - else { - additem(); - } - $zinc->translate($currentitem, $x, $y); - $zinc->translate("axisgrp:$currentitem", $x, $y); -} - -sub removeitem { - if (defined($currentitem)) { - $zinc->remove($currentitem, "axisgrp:$currentitem"); - if ($currentitem == $currentgroup) { - $currentgroup = $world; - } - $currentitem = undef; - $composescale = $composerot = 1; - } -} diff --git a/Perl/demos/Tk/demos/zinc_lib/translation.pl b/Perl/demos/Tk/demos/zinc_lib/translation.pl deleted file mode 100644 index f6abb15..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/translation.pl +++ /dev/null @@ -1,144 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# This simple demo has been developped by C. Schlienger - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - - -use Tk; -use Tk::Zinc; -use strict; - - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); - -########################################### -# Text zone -########################################### - -my $text = $mw->Scrolled(qw/Text -relief sunken -borderwidth 2 -setgrid true - -height 6 -scrollbars e/); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', - 'This toy-appli shows translations on waypoint items. -The following operations are possible: - Click "Up" for up translation - Click "Left" for left translation - Click "Right" for right translation - Click "Down" for down translation' ); - -########################################### -# Zinc -########################################### -my $zinc_width=600; -my $zinc_height=400; -my $zinc = $mw->Zinc(-width => $zinc_width, -height => $zinc_height, - -font => "10x20", - -borderwidth => 3, -relief => 'sunken', - )->pack; - -########################################### -# Waypoints -########################################### - -my $wp_group = $zinc->add('group', 1, -visible => 1); - -my $p1=[200, 200]; -my $wp1 = $zinc->add('waypoint',$wp_group, 1, - -position => $p1, - -connectioncolor => 'green', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldx=>'-20' - ); -$zinc->itemconfigure($wp1, 0, - -text => "DO", - ); - -my $p2=[300, 300]; -my $wp2 = $zinc->add('waypoint',$wp_group, 1, - -position => $p2, - -connecteditem => $wp1, - -connectioncolor => 'blue', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldx=>'-20', - #-labeldy=>'30' - ); - -$zinc->itemconfigure($wp2, 0, - -text => "RE", - ); - -my $p3=[400, 150]; -my $wp3 = $zinc->add('waypoint', $wp_group, 2, - -position => $p3, - -connecteditem => $wp2, - -connectioncolor => 'blue', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldx=>'20', - -labeldy=>'+10' - ); -$zinc->itemconfigure($wp3, 0, - -text => "MI", - ); - -################################################### -# control panel -################################################### -my $rc = $mw->Frame()->pack(); -my $up=$rc->Button(-width => 2, - -height => 2, - -text => 'Up', - -command=>sub{ - #-------------------------------- - # Up translation - #-------------------------------- - $zinc->translate("$wp_group",0,-10); - })->grid(-row => 0, - -column => 1); - -my $left=$rc->Button(-width => 2, - -height => 2, - -text => 'Left', - -command=>sub{ - #-------------------------------- - # Left translation - #-------------------------------- - $zinc->translate("$wp_group",-10,0); - })->grid(-row => 1, - -column => 0); - -my $right=$rc->Button(-width => 2, - -height => 2, - -text => 'Right', - -command=>sub{ - #-------------------------------- - # Right translation - #-------------------------------- - $zinc->translate("$wp_group",10,0); - })->grid(-row => 1, - -column => 2); - -my $down=$rc->Button(-width => 2, - -height => 2, - -text => 'Down', - -command=>sub{ - #-------------------------------- - # Down translation - #-------------------------------- - $zinc->translate("$wp_group",0,10); - })->grid(-row => 2, - -column => 1); - - - - -MainLoop; diff --git a/Perl/demos/Tk/demos/zinc_lib/triangles.pl b/Perl/demos/Tk/demos/zinc_lib/triangles.pl deleted file mode 100644 index 2dfba41..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/triangles.pl +++ /dev/null @@ -1,58 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# these simple samples have been developped by C. Mertz mertz@cena.fr and N. Banoun banoun@cena.fr - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; -use strict; - - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); -my $zinc = $mw->Zinc(-width => 700, -height => 300, - -font => "10x20", # usually fonts are sets in resources - # but for this example it is set in the code! - -render => 1, - -borderwidth => 3, -relief => 'sunken', - )->pack; - -# 6 equilateral triangles around a point -$zinc->add('text', 1, - -position => [ 5,10 ], - -text => "Triangles item without transparency"); - -my ($x0,$y0) = (200,150); -my @coords=($x0,$y0); -for my $i (0..6) { - my $angle = $i * 6.28/6; - push @coords, ($x0 + 100 * cos ($angle), $y0 - 100 * sin ($angle) ); -} - -my $tr1 = $zinc->add('triangles', 1, - \@coords, - -fan => 1, - -colors => ['white', 'yellow', 'magenta', 'blue', 'cyan', 'green', 'red', 'yellow'], - -visible => 1, - ); - -$zinc->add('text', 1, - -position => [ 370, 10 ], - -text => "Triangles item with transparency"); - - -# using the clone method to make a copy and then modify the clone'colors -my $tr2 = $zinc->clone($tr1); -$zinc->translate($tr2,300,0); -$zinc->itemconfigure($tr2, - -colors => ['white;50', 'yellow;50', 'magenta;50', 'blue;50', 'cyan;50', 'green;50', 'red;50', 'yellow;50'], - ); - - - -MainLoop; - - - diff --git a/Perl/demos/Tk/demos/zinc_lib/wheelOfFortune.pl b/Perl/demos/Tk/demos/zinc_lib/wheelOfFortune.pl deleted file mode 100644 index cf117a5..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/wheelOfFortune.pl +++ /dev/null @@ -1,374 +0,0 @@ -#!/usr/bin/perl -# -# This short script tries to demonstrate with a simple example what you can -# do with Tk Zinc widget, in particular how to use group item, clipping, and -# transformations. -# $Id$ -# this demo has been developped by D. Etienne etienne@cena.fr -# - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -# Zinc module is loaded... -use Tk::Zinc; - - -# We create a classical root widget called MainWindow; then we create Zinc -# widget child with size, color and relief attributes, and we display it using -# the geometry manager called 'pack'. -my $mw = MainWindow->new; -$mw->geometry("320x565"); -$mw->resizable(0,0); -my $zinc = $mw->Zinc(-width => 300, -height => 500, -backcolor => 'gray70', - -borderwidth => 3, -relief => 'sunken'); -$zinc->pack; - -# Then we create a gray filled rectangle, in which we will display explain text. -$zinc->add('rectangle', 1 , [10, 400, 290, 490], - -linewidth => 0, - -filled => 1, - -fillcolor => 'gray80', - ); -my $text = $zinc->add('text', 1, - -position => [150, 445], - -anchor => 'center', - ); - -# Create the Wheel object (see Wheel.pm) -my $wheel = Wheel->new($zinc, 150, 500, 100); - -# Display comment -&comment("Strike any key to begin"); - -# Create Tk binding -$mw->Tk::bind('', \&openmode); - - - -MainLoop; - - - -# Callback bound to '' event when wheel is unmapped -sub openmode { - return if $wheel->ismoving; - # set binding to unmap the wheel - $mw->Tk::bind('', \&closemode); - # set binding to rotate the hand - $zinc->bind($wheel, '<1>', sub {$wheel->rotatehand(300)}); - # map the wheel - $wheel->show(150, 150); - # and then inform user - &comment("Click on the wheel to rotate the hand.\n". - "Strike any other key to hide the wheel."); -} - -# Callback bound to '' event when wheel is already mapped -sub closemode { - return if $wheel->ismoving; - # set binding to map the wheel - $mw->Tk::bind('', \&openmode); - # unmap the wheel - $wheel->hide(150, 400); - # and then inform user - &comment("Strike any key to show the wheel"); -} - -# Just display comment -sub comment { - my $string = shift; - $zinc->itemconfigure($text, -text => $string); -} - - - -#============================================================================= -# Wheel Class -#============================================================================= -package Wheel; - -use strict 'vars'; -use Carp; - - -#==================== -# Object constructor -#==================== -sub new { - my ($proto, $widget, $x, $y, $radius) = @_; - - # object attributes - my $self = { - 'widget' => $widget, # widget reference - 'origin' => [$x, $y], # origin coordinates - 'radius' => $radius, # wheel radius - 'topgroup' => undef, # top Group item - 'itemclip' => undef, # id of item which clips the wheel - 'hand' => undef, # id of item wich represents the hand - 'angle' => 60, # the angle between hand and jackpot - 'stepsnumber' => 10, # animations parameters - 'afterdelay' => 60, - 'shrinkrate' => 0.8, # zoom parameters - 'zoomrate' => 1.1 - }; - bless $self; - - # First, we create a new Group item for the wheel. Why a Group item ? - # At least two reasons. Wheel object consists of several Zinc items, - # we'll see below; it moves when it is mapped or unmapped, grows when - # you hit the jackpot. So, it's more easy to apply such transformations - # to a structured items set, using Group capability, rather than apply - # to each item separately or using canvas-like Tags mechanism. - # Second reason refers to clipping. When it is mapped or unmapped, wheel - # object is drawn inside a circle with variant radius; clipping is a - # specific property of Group item - - # That's why we create a Group item in the top group, and set its - # coordinates. - $self->{topgroup} = $widget->add('group', 1, -visible => 0); - $widget->coords($self->{topgroup}, [$x, $y]); - # All the following items will be created in this group... - - # Create the invisible Arc item used to clip the wheel, centered on the - # group origin. - $self->{itemclip} = $widget->add('arc', $self->{topgroup}, - [-$radius, -$radius, $radius, $radius], - -visible => 0, - ); - $widget->itemconfigure($self->{topgroup}, -clip => $self->{itemclip}); - - # Create the wheel with 6 filled Arc items centered on the group origin - my $i = 0; - for my $color (qw(magenta blue cyan green yellow red)) { - $widget->add('arc', $self->{topgroup}, - [-$radius, -$radius, $radius, $radius], - -visible => 1, - -filled => 1, - -closed => 1, - -extent => 60, - -pieslice => 1, - -fillcolor => $color, - -linewidth => 0, - -startangle => 60*$i , - -tags => [$self], - ); - $i++; - } - - # Create the Text item representing the jackpot. - $widget->add('text', $self->{topgroup}, - -position => [0, -$radius+20], - -font => - '-adobe-helvetica-bold-o-normal--34-240-100-100-p-182-iso8859-1', - -anchor => 'center', - -text => "\$", - ); - - # Create the closed Curve item representing the hand. - # In order to make processing easier, its rotation axis will be placed - # on the group origin. - $self->{hand} = $widget->add('curve', $self->{topgroup}, - [0, -$radius + 10, 20, -$radius + 40, - 6, -$radius + 40, 20, 10, - -20, 10, -6, -$radius + 40, - -20, -$radius + 40], - -linewidth => 3, - -linecolor => 'gray40', - -filled => 1, - -fillcolor => 'gray80', - -closed => 1, - -tags => [$self]); - # Then, we apply rotation to the hand using the Zinc 'rotation' method. - $widget->rotate($self->{hand}, 3.1416/3); - - # Then we unmap the wheel; in fact, Group item is translated and its - # clipping circle is shrunk to a point. - $self->_clipAndTranslate($self->{shrinkrate}**$self->{stepsnumber}); - - return $self; - -} - -#================ -# Public methods -#================ - -# Return 1 if wheel is moving (opening or closing animation) -sub ismoving { - my $self = shift; - return 1 if $self->{opening} or $self->{closing}; -} - -# Display wheel with animation effect -sub show { - my ($self, $x, $y) = @_; - # simple lock management - return if $self->{opening} or $self->{closing}; - $self->{opening} = 1; - # start animation - $self->_open($x, $y, 0); -} - - -# Unmap wheel with animation effect -sub hide { - my ($self, $x, $y) = @_; - # simple lock management - return if $self->{opening} or $self->{closing}; - $self->{closing} = 1; - # start animation - $self->_close($x, $y, 0); -} - - -# Just rotate the hand with animation effect. -sub rotatehand { - my $self = shift; - my $angle = shift; - return if $self->{turning}; - $angle = 360 unless $angle; - $self->{angle} += $angle; - if ($self->{angle} % 360 == 0) { - $self->{fortune} = 1; - } - $self->_rotatehand(2*3.1416*$angle/360); -} - - -#================= -# Private methods -#================= - -# Generate opening animation; see below _clipAndTranslate method for -# Zinc specific use. -sub _open { - my ($self, $x, $y, $cnt) = @_; - my $widget = $self->{widget}; - my $group = $self->{topgroup}; - # first step of animation - if ($cnt == 0) { - $widget->itemconfigure($group, -visible => 1); - my @pos = $widget->coords($group); - $x = ($x - $pos[0])/$self->{stepsnumber}; - $y = ($y - $pos[1])/$self->{stepsnumber}; - # last step - } elsif ($cnt == $self->{stepsnumber}) { - $self->{opening} = undef; - return; - } - $cnt++; - # move and grow the wheel - $self->_clipAndTranslate(1/$self->{shrinkrate}, $x, $y); - # process the animation using the 'after' Tk defering method - $widget->after($self->{afterdelay}, sub {$self->_open($x, $y, $cnt)}); -} - - -# Generate closing animation; see below _clipAndTranslate method for -# Zinc specific use. -sub _close { - my ($self, $x, $y, $cnt) = @_; - my $widget = $self->{widget}; - my $group = $self->{topgroup}; - # first step of animation - if ($cnt == 0) { - my @pos = $widget->coords($group); - $x = ($x - $pos[0])/$self->{stepsnumber}; - $y = ($y - $pos[1])/$self->{stepsnumber}; - # last step - } elsif ($cnt == $self->{stepsnumber}) { - $widget->itemconfigure($group, -visible => 0); - $self->{closing} = undef; - return; - } - $cnt++; - # move and shrink the wheel - $self->_clipAndTranslate($self->{shrinkrate}, $x, $y); - # process the animation using the 'after' Tk defering method - $widget->after($self->{afterdelay}, sub {$self->_close($x, $y, $cnt)}); -} - - -# Generate hand rotation animation. -sub _rotatehand { - my ($self, $angle, $cnt) = @_; - my $widget = $self->{widget}; - my $group = $self->{topgroup}; - $self->{turning} = 1; - # first step of animation - if (not $cnt) { - $angle /= $self->{stepsnumber}; - # last step - } elsif ($cnt == $self->{stepsnumber}) { - if ($self->{fortune}) { - $self->_fortune; - } else { - $self->{turning} = undef; - } - return; - } - $cnt++; - # use 'rotation' Zinc method. - $widget->rotate($self->{hand}, $angle); - - # process the animation using the 'after' Tk defering method - $widget->after($self->{afterdelay}, sub {$self->_rotatehand($angle, $cnt)}); - -} - -# Generate growing animation to notify jackpot -sub _fortune { - my ($self, $cnt) = @_; - $cnt = 0 unless $cnt; - my $zf; - my $widget = $self->{widget}; - my $group = $self->{topgroup}; - my @pos = $widget->coords($group); - # last step of animation - if ($cnt == 6) { - $self->{fortune} = undef; - $self->{turning} = undef; - return; - # event steps : wheel grows - } elsif ($cnt == 0 or $cnt % 2 == 0) { - $zf = $self->{zoomrate}; - # odd steps : wheel is shrunk - } else { - $zf = 1/$self->{zoomrate}; - } - $cnt++; - - # Now, we apply scale transformation to the Group item, using the 'scale' - # Zinc method. Note that we reset group coords before scaling it, in order - # that the origin of the transformation corresponds to the center of the - # wheel. When scale is done, we restore previous coords of group. - $widget->coords($group, [0, 0]); - $widget->scale($group, $zf, $zf); - $widget->coords($group, \@pos); - - # process the animation using the 'after' Tk defering method - $widget->after(100, sub {$self->_fortune($cnt)}); - -} - -# Update group clipping and translation, using 'scale' and 'translate' -# Zinc methods. -sub _clipAndTranslate { - - my ($self, $shrinkfactor, $x, $y) = @_; - $x = 0 unless $x; - $y = 0 unless $y; - $self->{widget}->scale($self->{itemclip}, $shrinkfactor, $shrinkfactor); - if ($Tk::Zinc::VERSION lt "3.297") { - $self->{widget}->translate($self->{topgroup}, $x, $y); - } else { - my ($xc, $yc) = $self->{widget}->coords($self->{topgroup}); - $self->{widget}->coords($self->{topgroup}, [$xc + $x, $yc + $y]); - } - -} - - -1; diff --git a/Perl/demos/Tk/demos/zinc_lib/window-contours.pl b/Perl/demos/Tk/demos/zinc_lib/window-contours.pl deleted file mode 100644 index 9f16f95..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/window-contours.pl +++ /dev/null @@ -1,112 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# This simple demo has been developped by C. Mertz - -package window_contours; # for avoiding symbol collision between different demos - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -use Tk; -use Tk::Zinc; - -use strict; - -my $mw = MainWindow->new(); - - -# Creating the zinc widget -my $zinc = $mw->Zinc(-width => 600, -height => 500, - -font => "9x15", # usually fonts are sets in resources - # but for this example it is set in the code! - -borderwidth => 3, -relief => 'sunken', - )->pack; - -# The explanation displayed when running this demo -$zinc->add('text', 1, - -position=> [10,10], - -text => 'These "windows" are simply rectangles holed by 4 smaller -rectangles. The text appears behind the window glasses. -You can drag text or "windows".', - -font => "10x20", - ); - -# Text in background -my $backtext = $zinc->add('text', 1, - -position=> [50,200], - -text => "This text appears\nthrough holes of curves", - -font => "-adobe-helvetica-bold-o-normal--34-240-100-100-p-182-iso8859-1", - ); - -my $window = $zinc->add('curve', 1, [100,100 , 300,100, 300,400 , 100,400 ], - -closed => 1, -visible => 1, -filled => 1, - -fillcolor => "grey66", - ); - -my $aGlass= $zinc->add('rectangle', 1, [120,120 , 190,240]); -$zinc->contour($window, 'add', +1, $aGlass); - -$zinc->translate($aGlass, 90,0); -$zinc->contour($window, 'add', +1, $aGlass); - -$zinc->translate($aGlass, 0,140); -$zinc->contour($window, 'add', +1, $aGlass); - -$zinc->translate($aGlass, -90,0); -$zinc->contour($window, 'add', +1, $aGlass); - -# deleting $aGlass which is no more usefull -$zinc->remove($aGlass); - -# cloning $window -my $window2 = $zinc->clone($window); - -# changing its background, moving it and scaling it! -$zinc->itemconfigure($window2, -fillcolor => "grey50"); -$zinc->translate($window2, 30,50); -$zinc->scale($window, 0.8, 0.8); - - - - -# adding drag and drop callback to the two windows and backtext -foreach my $item ($window, $window2, $backtext) { - # Some bindings for dragging the items - $zinc->bind($item, '' => [\&press, $item, \&motion]); - $zinc->bind($item, '' => \&release); -} - -# callback for starting a drag -my ($x_orig, $y_orig); -sub press { - my ($zinc, $item, $action) = @_; - my $ev = $zinc->XEvent(); - $x_orig = $ev->x; - $y_orig = $ev->y; - $zinc->Tk::bind('', [$action, $item]); -} - -# Callback for moving an item -sub motion { - my ($zinc, $item) = @_; - my $ev = $zinc->XEvent(); - my $x = $ev->x; - my $y = $ev->y; - - $zinc->translate($item, $x-$x_orig, $y-$y_orig); - $x_orig = $x; - $y_orig = $y; -} - - -# Callback when releasing the mouse button. It removes any motion callback -sub release { - my ($zinc) = @_; - $zinc->Tk::bind('', ''); -} - - -Tk::MainLoop(); - - -1; diff --git a/Perl/demos/Tk/demos/zinc_lib/zoom.pl b/Perl/demos/Tk/demos/zinc_lib/zoom.pl deleted file mode 100644 index a1ad925..0000000 --- a/Perl/demos/Tk/demos/zinc_lib/zoom.pl +++ /dev/null @@ -1,180 +0,0 @@ -#!/usr/bin/perl -# $Id$ -# This simple demo has been developped by C. Schlienger - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - - -use Tk; -use Tk::Zinc; -use strict; - - -my $defaultfont = '-adobe-helvetica-bold-r-normal--*-120-*-*-*-*-*-*'; -my $mw = MainWindow->new(); - -########################################### -# Text zone -########################################### - -my $text = $mw->Text(-relief => 'sunken', -borderwidth => 2, -height => 4); -$text->pack(qw/-expand yes -fill both/); - -$text->insert('0.0', - 'This toy-appli shows zoom actions on waypoint and curve items. -The following operations are possible: - Click "-" to zoom out - Click "+" to zoom in ' ); - -########################################### -# Zinc -########################################### -my $zinc_width=600; -my $zinc_height=500; -my $zinc = $mw->Zinc(-width => $zinc_width, -height => $zinc_height, - -font => "10x20", - -borderwidth => 3, -relief => 'sunken', - )->pack; - -########################################### -# Waypoints and sector -########################################### - -my $wp_group = $zinc->add('group', 1, -visible => 1); - -my $p1=[200, 100]; -my $wp1 = $zinc->add('waypoint',$wp_group, 1, - -position => $p1, - -connectioncolor => 'green', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldx=>'-20' - ); -$zinc->itemconfigure($wp1, 0, - -text => "DO", - ); - -my $p2=[300, 150]; -my $wp2 = $zinc->add('waypoint',$wp_group, 1, - -position => $p2, - -connecteditem => $wp1, - -connectioncolor => 'blue', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldx=>'-20', - ); - -$zinc->itemconfigure($wp2, 0, - -text => "RE", - ); - -my $p3=[400, 50]; -my $wp3 = $zinc->add('waypoint', $wp_group, 2, - -position => $p3, - -connecteditem => $wp2, - -connectioncolor => 'blue', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldx=>'20', - -labeldy=>'+10' - ); -$zinc->itemconfigure($wp3, 0, - -text => "MI", - ); - -my $p4=[350, 450]; -my $wp4 = $zinc->add('waypoint', $wp_group, 2, - -position => $p4, - -connecteditem => $wp2, - -connectioncolor => 'blue', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldy=>'-15' - ); -$zinc->itemconfigure($wp4, 0, - -text => "FA", - ); - - -my $p5=[300, 250]; -my $wp5 = $zinc->add('waypoint', $wp_group, 2, - -position => $p5, - -connectioncolor => 'blue', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldy=>'-15' - ); -$zinc->itemconfigure($wp5, 0, - -text => "SOL", - ); - - -my $p6=[170, 240]; -my $wp6 = $zinc->add('waypoint', $wp_group, 2, - -position => $p6, - -connecteditem => $wp5, - -connectioncolor => 'blue', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldx=>'-20' - ); -$zinc->itemconfigure($wp6, 0, - -text => "LA", - ); - -my $p7=[550, 200]; -my $wp7 = $zinc->add('waypoint', $wp_group, 2, - -position => $p7, - -connecteditem => $wp5, - -connectioncolor => 'blue', - -symbolcolor => 'blue', - -labelformat => 'x20x18+0+0', - -leaderwidth=>'0', - -labeldx=>'20' - ); -$zinc->itemconfigure($wp7, 0, - -text => "SI", - ); - - -my $sector = $zinc ->add('curve',$wp_group,[300,0,400,50,500,100,550,200,550,400,350,450,170,240,200,100,300,0]); - -################################################### -# control panel -################################################### -my $rc = $mw->Frame()->pack(); - -#the reference of the scale function is top-left corner of the zinc object -#so we first translate the group to zoom in order to put its center on top-left corner -#change the scale of the group -#translate the group to put it back at the center of the zinc object - -my $minus=$rc->Button(-width => 2, - -height => 2, - -text => '-', - -command=>sub{ - $zinc->translate($wp_group,-$zinc_width/2,-$zinc_height/2); - $zinc->scale($wp_group,0.8,0.8); - $zinc->translate($wp_group, $zinc_width/2,$zinc_height/2); - })->pack(-side=>'left'); - - -my $plus=$rc->Button(-width => 2, - -height => 2, - -text => '+', - -command=>sub{ - $zinc->translate($wp_group, -$zinc_width/2,-$zinc_height/2); - $zinc->scale($wp_group,1.2,1.2); - $zinc->translate($wp_group,$zinc_width/2,$zinc_height/2); - })->pack(-side => 'right'); - - - -MainLoop; diff --git a/Perl/demos/Tk/demos/zinc_pm/SimpleRadarControls.pm b/Perl/demos/Tk/demos/zinc_pm/SimpleRadarControls.pm deleted file mode 100644 index 723f3ec..0000000 --- a/Perl/demos/Tk/demos/zinc_pm/SimpleRadarControls.pm +++ /dev/null @@ -1,235 +0,0 @@ -package SimpleRadarControls; - -# $Id$ -# This simple radar has been initially developped by P. Lecoanet -# It has been adapted by C. Mertz for demo purpose. -# Thanks to Dunnigan,Jack [Edm]" for a bug correction. - - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -$top = 1; - -sub new { - my $proto = shift; - my $type = ref($proto) || $proto; - my ($zinc) = @_; - my $self = {}; - - $self{'zinc'} = $zinc; - $self{'cur_x'} = 0; - $self{'cur_y'} = 0; - $self{'cur_angle'} = 0; - $self{'corner_x'} = 0; - $self{'corner_y'} = 0; - - $self{'tlbbox'} = $zinc->add('group', $top, - -sensitive => 0, -visible => 0, - -tags => 'currentbbox'); - $zinc->add('rectangle', $self{'tlbbox'}, [-3, -3, +3, +3]); - $self{'trbbox'} = $zinc->add('group', $top, - -sensitive => 0, -visible => 0, - -tags => 'currentbbox'); - $zinc->add('rectangle', $self{'trbbox'}, [-3, -3, +3, +3]); - $self{'blbbox'} = $zinc->add('group', $top, - -sensitive => 0, -visible => 0, - -tags => 'currentbbox'); - $zinc->add('rectangle', $self{'blbbox'}, [-3, -3, +3, +3]); - $self{'brbbox'} = $zinc->add('group', $top, - -sensitive => 0, -visible => 0, - -tags => 'currentbbox'); - $zinc->add('rectangle', $self{'brbbox'}, [-3, -3, +3, +3]); - $zinc->add('rectangle', $top, [0, 0, 1, 1], - -linecolor => 'red', -tags => 'lasso', - -visible => 0, -sensitive => 0); - - $zinc->Tk::bind('', [\&start_lasso, $self]); - $zinc->Tk::bind('', [\&fin_lasso, $self]); - - $zinc->Tk::bind('', sub { my $ev = $zinc->XEvent(); - my @closest = $zinc->find('closest', - $ev->x, $ev->y); - print "at point=$closest[0]\n" }); - - $zinc->Tk::bind('', [\&press, $self, \&motion]); - $zinc->Tk::bind('', [\&release, $self]); - - $zinc->Tk::bind('', [\&press, $self, \&zoom]); - $zinc->Tk::bind('', [\&release, $self]); - - $zinc->Tk::bind('', [\&press, $self, \&rotate]); - $zinc->Tk::bind('', [\&release, $self]); - - $zinc->Tk::bind('current', '', [\&showbox, $self]); - $zinc->Tk::bind('current', '', [\&hidebox, $self]); - - bless ($self, $type); - return $self; -} - -# -# Controls for the window transform. -# -sub press { - my ($zinc, $self, $action) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - - $self->{'cur_x'} = $lx; - $self->{'cur_y'} = $ly; - $self->{'cur_angle'} = atan2($ly, $lx); - $zinc->Tk::bind('', [$action, $self]); -} - -sub motion { - my ($zinc, $self) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my @it; - my @res; - - @it = $zinc->find('withtag', 'controls'); - if (scalar(@it) == 0) { - return; - } - @res = $zinc->transform($it[0], [$lx, $ly, $self->{'cur_x'}, $self->{'cur_y'}]); - $zinc->translate('controls', $res[0] - $res[2], $res[1] - $res[3]); - $self->{'cur_x'} = $lx; - $self->{'cur_y'} = $ly; -} - -sub zoom { - my ($zinc, $self) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my $maxx; - my $maxy; - my $sx; - my $sy; - - if ($lx > $self->{'cur_x'}) { - $maxx = $lx; - } else { - $maxx = $self->{'cur_x'}; - } - if ($ly > $self->{'cur_y'}) { - $maxy = $ly - } else { - $maxy = $self->{'cur_y'}; - } - #avoid illegal division by zero - return unless ($maxx && $maxy); - - $sx = 1.0 + ($lx - $self->{'cur_x'})/$maxx; - $sy = 1.0 + ($ly - $self->{'cur_y'})/$maxy; - $self->{'cur_x'} = $lx if ($lx>0); # avoid ZnTransfoDecompose :singular matrix - $self->{'cur_y'} = $ly if ($ly>0); # error messages - $zinc->scale('controls', $sx, $sy); -# $main::scale *= $sx; -# main::update_transform($zinc); -} - -sub rotate { - my ($zinc, $self) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my $langle; - - $langle = atan2($ly, $lx); - $zinc->rotate('controls', -($langle - $self->{'cur_angle'})); - $self->{'cur_angle'} = $langle; -} - -sub release { - my ($zinc, $self) = @_; - $zinc->Tk::bind('', ''); -} - -sub start_lasso { - my ($zinc, $self) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my @coords; - - $self->{'cur_x'} = $lx; - $self->{'cur_y'} = $ly; - $self->{'corner_x'} = $lx; - $self->{'corner_y'} = $ly; - @coords = $zinc->transform($top, [$lx, $ly]); - $zinc->coords('lasso', [$coords[0], $coords[1], $coords[0], $coords[1]]); - $zinc->itemconfigure('lasso', -visible => 1); - $zinc->raise('lasso'); - $zinc->Tk::bind('', [\&lasso, $self]); -} - -sub lasso { - my ($zinc, $self) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my @coords; - - $self->{'corner_x'} = $lx; - $self->{'corner_y'} = $ly; - @coords = $zinc->transform($top, [$self->{'cur_x'}, $self->{'cur_y'}, $lx, $ly]); - $zinc->coords('lasso', [$coords[0], $coords[1], $coords[2], $coords[3]]); -} - -sub fin_lasso { - my ($zinc, $self) = @_; - my $enclosed; - my $overlapping; - - $zinc->Tk::bind('', ''); - $zinc->itemconfigure('lasso', -visible => 0); - $enclosed = join(', ', $zinc->find('enclosed', - $self->{'cur_x'}, $self->{'cur_y'}, - $self->{'corner_x'}, $self->{'corner_y'})); - $overlapping = join(', ', $zinc->find('overlapping', - $self->{'cur_x'}, $self->{'cur_y'}, - $self->{'corner_x'}, $self->{'corner_y'})); - print "enclosed=$enclosed, overlapping=$overlapping\n"; -} - -sub showbox { - my ($zinc, $self) = @_; - my @coords; - my @it; - - if (! $zinc->hastag('current', 'currentbbox')) { - @it = $zinc->find('withtag', 'current'); - if (scalar(@it) == 0) { - return; - } - @coords = $zinc->transform($top, $zinc->bbox('current')); - - $zinc->coords($self->{'tlbbox'}, [$coords[0], $coords[1]]); - $zinc->coords($self->{'trbbox'}, [$coords[2], $coords[1]]); - $zinc->coords($self->{'brbbox'}, [$coords[2], $coords[3]]); - $zinc->coords($self->{'blbbox'}, [$coords[0], $coords[3]]); - $zinc->itemconfigure('currentbbox', -visible => 1); - } -} - -sub hidebox { - my ($zinc, $self) = @_; - my $ev = $zinc->XEvent(); - my $lx = $ev->x; - my $ly = $ev->y; - my @next; - - @next = $zinc->find('closest', $lx, $ly); - if ((scalar(@next) == 0) || - ! $zinc->hastag($next[0], 'currentbbox') || - $zinc->hastag('current', 'currentbbox')) { - $zinc->itemconfigure('currentbbox', -visible => 0); - } -} - - diff --git a/Perl/demos/t/no-test.t b/Perl/demos/t/no-test.t deleted file mode 100644 index a317b57..0000000 --- a/Perl/demos/t/no-test.t +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/perl - -BEGIN { $| = 1; print "1..1\n"; } -END {print "ok 1\n";} - -print "No test for zinc demos, since they are by themselves Tk::Zinc tests\n"; - -1; diff --git a/Perl/demos/zinc-demos b/Perl/demos/zinc-demos deleted file mode 100644 index 2bffb5a..0000000 --- a/Perl/demos/zinc-demos +++ /dev/null @@ -1,502 +0,0 @@ -#!/usr/bin/perl -w - -#$id: $ - -eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}' - if 0; # not running under some shell - -require 5.004; - -use Tk 800.000; -use Tk::Zinc; # only for getting $Tk::Zinc::VERSION -use lib Tk->findINC('demos/widget_lib'); -use Tk::widgets qw/Dialog ErrorDialog ROText/; -use WidgetDemo; -use subs qw/invoke lsearch see_code see_vars show_stat view_widget_code/; -use vars qw/$MW $FONT $WIDTRIB/; -use vars qw/$CODE $CODE_RERUN $CODE_TEXT $VARS $VIEW $VIEW_TEXT/; -use vars qw/$BRAKES $LIGHTS $OIL $SOBER $TRANS $WIPERS/; -use vars qw/$COLOR $FONT_STYLE $POINT_SIZE $DEMO_FILE %DEMO_DESCRIPTION/; -use strict; - -use vars qw( $VERSION ); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); - -my $version = $Tk::Zinc::VERSION; -print "Tkzinc version: $version\n"; - -$MW = Tk::MainWindow->new; -$MW->configure(-menu => my $menubar = $MW->Menu); - -{ - package WidgetWrap; - @WidgetWrap::ISA = qw/Tk::MainWindow/; - - # This magic conspires with widget's AUTOLOAD subroutine to make user - # contributed demonstrations that don't use WidgetDemo embed properly. - # The trick works because widget creates a superclass of Tk::MainWindow - # which invokes WidgetDemo() implicitly. You loose if you bypass the - # inheritance mechanism and call Tk::MainWindow directly. - - sub new { - my ($name) = $::DEMO_FILE =~ m#([^/]+).pl$#; - $::MW->WidgetDemo(-name => $name, -text => $::DEMO_DESCRIPTION{$name} || "" ); - } -} - -@MainWindow::ISA = 'WidgetWrap'; - -$MW->title('TkZinc Perl demonstrations'); -$FONT = '-*-Helvetica-Medium-R-Normal--*-140-*-*-*-*-*-*'; -my $widget_lib = Tk->findINC('demos/widget_lib'); -# the previous simple statement $zinc_lib = Tk->findINC('demos/zinc_lib'); -# found in some cases such old directory empty (e.g. after a previous package de-installation) -# So now, we look for a non-empty demos/zinc_lib directory (ie containing one of the demo!) -my $zinc_lib = Tk->findINC('demos/zinc_lib/tiger.pl'); -($zinc_lib) = $zinc_lib =~ /(.*)\/tiger\.pl/; -my $wd = "$widget_lib/WidgetDemo.pm"; -$WIDTRIB = Tk->findINC('demos/zinc_contrib_lib/README'); -($WIDTRIB) = $WIDTRIB =~ /(.*)\/README/; -unless (Tk::tainting) { - $WIDTRIB = $ENV{WIDTRIB} if defined $ENV{WIDTRIB}; - $WIDTRIB = $ARGV[0] if defined $ARGV[0]; -} - -# The code below creates the main window, consisting of a menu bar -# and a text widget that explains how to use the program, plus lists -# all of the demos as hypertext items. - -my $file = $menubar->cascade(qw/-label File -underline 0 -menuitems/ => - [ - [cascade => '~View', -menuitems => - [ - [command => '~zinc-demos', -command => [\&view_widget_code, __FILE__]], - [command => '~WidgetDemo', -command => [\&view_widget_code, $wd]], - ], # end cascade menuitems - ], # end view cascade - '', - [command => '~Quit', -command => [\&exit]], - ]); - -my $help = $menubar->cascade(qw/-label Help -underline 0 -menuitems/ => - [ - [command => '~About'], - ]); - -my $T = $MW->Scrolled('ROText', - -scrollbars => 'e', - -wrap => 'word', - -width => 60, - -height => 30, - -font => $FONT, - -setgrid => 1, -)->grid(qw/-sticky nsew/); -$MW->gridRowconfigure( 0, -weight => 1); # allow expansion in both ... -$MW->gridColumnconfigure(0, -weight => 1); # ... X and Y dimensions - -my $STATUS_VAR; -my $status = $MW->Label(-textvariable => \$STATUS_VAR, qw/-anchor w/); -$status->grid(qw/-sticky ew/); - -# Create a bunch of tags to use in the text widget, such as those for -# section titles and demo descriptions. Also define the bindings for -# tags. - -$T->tagConfigure(qw/title -font -*-Helvetica-Bold-R-Normal--*-180-*-*-*-*-*-*/); -$T->tagConfigure(qw/demo -lmargin1 1c -lmargin2 1c -foreground blue/); - -if ($MW->depth == 1) { - $T->tagConfigure(qw/hot -background black -foreground white/); - $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -underline 1/); -} else { - $T->tagConfigure(qw/hot -relief raised -borderwidth 1 -foreground red/); - $T->tagConfigure(qw/visited -lmargin1 1c -lmargin2 1c -foreground/ => - '#303080'); -} - -$T->tagBind(qw/demo / => \&invoke); -my $last_line = ''; -$T->tagBind(qw/demo / => [sub { - my($text, $sv) = @_; - my $e = $text->XEvent; - my($x, $y) = ($e->x, $e->y); - $last_line = $text->index("\@$x,$y linestart"); - $text->tagAdd('hot', $last_line, "$last_line lineend"); - $text->configure(qw/-cursor hand2/); - show_stat $sv, $text, $text->index('current'); - }, \$STATUS_VAR] -); -$T->tagBind(qw/demo / => [sub { - my($text, $sv) = @_; - $text->tagRemove(qw/hot 1.0 end/); - $text->configure(qw/-cursor xterm/); - $$sv = ''; - }, \$STATUS_VAR] -); -$T->tagBind(qw/demo / => [sub { - my($text, $sv) = @_; - my $e = $text->XEvent; - my($x, $y) = ($e->x, $e->y); - my $new_line = $text->index("\@$x,$y linestart"); - if ($new_line ne $last_line) { - $text->tagRemove(qw/hot 1.0 end/); - $last_line = $new_line; - $text->tagAdd('hot', $last_line, "$last_line lineend"); - } - show_stat $sv, $text, $text->index('current'); - }, \$STATUS_VAR] -); - -# Create the text for the text widget. - -$T->insert('end', "TkZinc perl Demonstrations ($version)\n", 'title'); -$T->insert('end', -"\nThis application provides a front end for several short scripts in perl/Tk that demonstrate what you can do with the TkZinc widget. Each of the numbered lines below describes a demonstration; you can click on it to invoke the demonstration. Once the demonstration window appears, you can click the \"See Code\" button to see the Perl/Tk code that created the demonstration.\n"); - -$T->insert('end', "\n", '', "Small applications\n", 'title'); -$T->insert('end', "1. A simple animated application \"the Wheel of Fortune\".\n", [qw/demo demo-wheelOfFortune/]); -$T->insert('end', "2. A simple radar display.\n", [qw/demo demo-simpleradar/]); -$T->insert('end', "3. Zetris a clone of the famous tetris game (requires openGL.)\n", [qw/demo demo-Zetris/]); -$T->insert('end', "4. ATC sample fake electronic strips (nicer with openGL.)\n", [qw/demo demo-groups_in_ATC_strips/]); -$T->insert('end', "5. The famous tiger using the X11 shape extension. (nicer with openGL)\n", [qw/demo demo-tiger/]); -$T->insert('end', "6. A magic lens based on Graphics.pm. (nicer with openGL)\n", [qw/demo demo-MagicLens/]); - - -$T->insert('end', "\n", '', "All Items\n", 'title'); -$T->insert('end', "1. Examples of all items.\n", [qw/demo demo-items/]); -$T->insert('end', "2. All items options (and their types).\n", [qw/demo demo-all_options/]); -$T->insert('end', "3. Examples of line style and line termination.\n", [qw/demo demo-lines/]); -$T->insert('end', "4. Curves with multiple contours.\n", [qw/demo demo-contours/]); -$T->insert('end', "5. Examples of labelformat.\n", [qw/demo demo-labelformat/]); -$T->insert('end', "6. Use of mapinfos.\n", [qw/demo demo-mapinfo/]); -$T->insert('end', "7. Curves with cubic bezier control points.\n", [qw/demo demo-curve_bezier/]); -$T->insert('end', "8. Curves with multiple contours and various fillrule.\n", [qw/demo demo-fillrule/]); - - -$T->insert('end', "\n", '', "Groups, Priority, Clipping and PathTags\n", 'title'); -$T->insert('end', "1. Groups and Priorities.\n", [qw/demo demo-groups_priority/]); -$T->insert('end', "2. Clipping examples (with simple or multiple contours).\n", [qw/demo demo-clipping/]); -$T->insert('end', "3. Group atomicity.\n", [qw/demo demo-atomic-groups/]); -$T->insert('end', "4. \"Windows\" with four glasses using curve with multiple contours.\n", [qw/demo demo-window-contours/]); -$T->insert('end', "5. A counter quite impossible to do without clipping (requires openGL).\n", [qw/demo demo-counter/]); -$T->insert('end', "6. Using pathTags.\n", [qw/demo demo-path_tags/]); - -$T->insert('end', "\n", '', "Interactions\n", 'title'); -$T->insert('end', "1. Simple interaction on a track.\n", [qw/demo demo-simple_interaction_track/]); -$T->insert('end', "2. Text input in a text item and a track item.\n", [qw/demo demo-textInput/]); - - -$T->insert('end', "\n", '', "Transformation\n", 'title'); -$T->insert('end', "1. Translating.\n", [qw/demo demo-translation/]); -$T->insert('end', "2. Rotating.\n", [qw/demo demo-rotation/]); -$T->insert('end', "3. Zooming.\n", [qw/demo demo-zoom/]); -$T->insert('end', "4. Transformation testbed.\n", [qw/demo demo-transforms/]); -$T->insert('end', "5. Zooming/Rotating icon and text. (even without openGL)\n", [qw/demo demo-icon_zoom_resize/]); - -$T->insert('end', "\n", '', "Use of openGL\n", 'title'); -$T->insert('end', "1. A zoomable/rotatable TkZinc Logo (better with openGL).\n", [qw/demo demo-tkZincLogo/]); -$T->insert('end', "2. Axial color variation on the X axis (requires openGL).\n", [qw/demo demo-color-x/]); -$T->insert('end', "3. Axial color variation on the Y axis (requires openGL).\n", [qw/demo demo-color-y/]); -$T->insert('end', "4. Circular color variation (requires openGL).\n", [qw/demo demo-color-circular/]); -$T->insert('end', "5. Path and Conical color variations (requires openGL).\n", [qw/demo demo-color-path-and-conic/]); -$T->insert('end', "6. The triangles item (requires openGL).\n", [qw/demo demo-triangles/]); -$T->insert('end', "7. A set of demos based on Graphics.pm module (really better with openGL).\n", [qw/demo demo-testGraphics/]); - - - -$T->insert('end', "\n", '', "User Contributed Demonstrations\n", 'title'); -opendir(C, $WIDTRIB) or warn "Cannot open $WIDTRIB: $!"; -my(@dirent) = grep /^.+\.pl$/, sort(readdir C); -closedir C; -unshift @dirent, 'TEMPLATE.pl'; # I want it first -my $i = 0; -while ($_ = shift @dirent) { - next if /TEMPLATE\.pl/ and $i != 0; - unless (open(C, "$WIDTRIB/$_")) { - warn "Cannot open $_: $!" unless /TEMPLATE\.pl/; - next; - } - my($name) = /^(.*)\.pl$/; - $_ = ; $_ = ; - my($title) = /^#\s*(.*)$/; - $DEMO_DESCRIPTION{$name} = $title; - close C; - $T->insert('end', ++$i . ". $title\n", ['demo', "demo-$name"]); -} - -# Create all the dialogs required by this demonstration. - -my $DIALOG_ABOUT = $MW->Dialog( - -title => 'About zinc-demos', - -bitmap => 'info', - -default_button => 'OK', - -buttons => ['OK'], - -text => "TkZinc Perl demonstrations\n\nPerl Version $]" . - "\nTk Version $Tk::VERSION" . - "\nTkZinc Version $Tk::Zinc::VERSION\n", -); -$help->cget(-menu)->entryconfigure('About', - -command => [$DIALOG_ABOUT => 'Show'], -); - -my $DIALOG_ICON = $MW->Dialog( - -title => 'Bitmap Menu Entry', - -bitmap => undef, - -default_button => 'OK', - -buttons => ['OK'], - -text => 'The menu entry you invoked displays a bitmap rather than a text string. Other than this, it is just like any other menu entry.', -); -$DIALOG_ICON->configure(-bitmap => undef); # keep -w from complaining - -MainLoop; - -sub AUTOLOAD { - - # This routine handles the loading of most demo methods. - - my($demo) = @_; - - $T->Busy; - { - $DEMO_FILE = "$WIDTRIB/${demo}.pl" if -f "$WIDTRIB/${demo}.pl"; - $DEMO_FILE = "$zinc_lib/${demo}.pl" if -f "$zinc_lib/${demo}.pl"; - if (defined $DEMO_FILE) { - do $DEMO_FILE ; - } else { warn "No such demo: $demo.pl in either $WIDTRIB/ or $zinc_lib/\n"; } - warn $@ if $@; - } - $T->Unbusy; - goto &$::AUTOLOAD if defined &$::AUTOLOAD; - -} # end AUTOLOAD - -sub invoke { - - # This procedure is called when the user clicks on a demo description. - - my($text) = @_; - - my $index = $text->index('current'); - my @tags = $T->tagNames($index); - my $i = lsearch('demo\-.*', @tags); - return if $i < 0; - my($demo) = $tags[$i] =~ /demo-(.*)/; - $T->tagAdd('visited', "$index linestart", "$index lineend"); - { - no strict 'refs'; - &$demo($demo); - } - -} # end invoke - -sub lsearch { - - # Search the list using the supplied regular expression and return it's - # ordinal, or -1 if not found. - - my($regexp, @list) = @_; - my($i); - - for ($i=0; $i<=$#list; $i++) { - return $i if $list[$i] =~ /$regexp/; - } - return -1; - -} # end lsearch - -sub see_code { - - # This procedure creates a toplevel window that displays the code for - # a demonstration and allows it to be edited and reinvoked. - - my($demo) = @_; - - my $file = "${demo}.pl"; - if (not Exists $CODE) { - $CODE = $MW->Toplevel; - my $code_buttons = $CODE->Frame; - $code_buttons->pack(qw/-side bottom -fill x/); - my $code_buttons_dismiss = $code_buttons->Button( - -text => 'Dismiss', - -command => [$CODE => 'withdraw'], - ); - $CODE_RERUN = $code_buttons->Button(-text => 'Rerun Demo'); - $CODE_TEXT = $CODE->Scrolled('Text', - qw/-scrollbars e -height 40 -setgrid 1/); - $code_buttons_dismiss->pack(qw/-side left -expand 1/); - $CODE_RERUN->pack(qw/-side left -expand 1/); - $CODE_TEXT->pack(qw/-side left -expand 1 -fill both/); - } else { - $CODE->deiconify; - $CODE->raise; - } - $CODE_RERUN->configure(-command => sub { - eval $CODE_TEXT->get(qw/1.0 end/); - { - no strict 'refs'; - &$demo($demo); - } - }); - $CODE->iconname($file); - $file = "$WIDTRIB/${demo}.pl" if -f "$WIDTRIB/${demo}.pl"; - $file = "$zinc_lib/${demo}.pl" if -f "$zinc_lib/${demo}.pl"; - $CODE->title("Demo code: $file"); - $CODE_TEXT->delete(qw/1.0 end/); - open(CODE, "<$file") or warn "Cannot open demo file $file: $!"; - { - local $/ = undef; - $CODE_TEXT->insert('1.0', ); - } - close CODE; - $CODE_TEXT->markSet(qw/insert 1.0/); - -} # end see_code - -sub see_vars { - - # Create a top-level window that displays a bunch of global variable values - # and keeps the display up-to-date even when the variables change value. - # $args is a pointer to a list of list of 2: - # - # ["variable description", \$VAR] - # - # The old trick of passing a string to serve as the description and a soft - # reference to the variable no longer works with lexicals and use strict. - - my($parent, $args) = @_; - - $VARS->destroy if Exists($VARS); - $VARS = $parent->Toplevel; - $VARS->geometry('+300+300'); - $VARS->title('Variable Values'); - $VARS->iconname('Variables'); - - my $title = $VARS->Label( - -text => 'Variable Values:', - -width => 20, - -anchor => 'center', - -font => '-*-helvetica-medium-r-normal--*-180-*-*-*-*-*-*', - ); - $title->pack(qw/-side top -fill x/); - my($label, $var); - foreach my $i (@$args) { - ($label, $var) = @$i; - my $wf = $VARS->Frame->pack(qw/-anchor w/); - $wf->Label(-text => "$label: ")->pack(qw/-side left/); - $wf->Label(-textvariable => $var)->pack(qw/-side left/); - } - $VARS->Button(-text => 'OK', -command => [$VARS => 'destroy'])-> - pack(qw/-side bottom -pady 2/); - -} # end see_vars - -sub show_stat { - - # Display name of current demonstration. $sv is a reference to the - # status Label -textvariable, $text is the Text widget reference and - # $index is the demonstration index in the Text widget. - - my($sv, $text, $index) = @_; - - my @tags = $text->tagNames($index); - my $i = lsearch('demo\-.*', @tags); - return if $i < 0; - my($demo) = $tags[$i] =~ /demo-(.*)/; - $$sv = "Click Button-1 to run the \"$demo\" demonstration."; - -} # end show_stat - -sub view_widget_code { - - # Expose a file's innards to the world too, but only for viewing. - - my($widget) = @_; - - if (not Exists $VIEW) { - $VIEW = $MW->Toplevel; - $VIEW->iconname('widget'); - my $view_buttons = $VIEW->Frame; - $view_buttons->pack(qw/-side bottom -expand 1 -fill x/); - my $view_buttons_dismiss = $view_buttons->Button( - -text => 'Dismiss', - -command => [$VIEW => 'withdraw'], - ); - $view_buttons_dismiss->pack(qw/-side left -expand 1/); - $VIEW_TEXT = $VIEW->Scrolled('Text', - qw/-scrollbars e -height 40 -setgrid 1/); - $VIEW_TEXT->pack(qw/-side left -expand 1 -fill both/); - } else { - $VIEW->deiconify; - $VIEW->raise; - } - $VIEW->title("Demo code: $widget"); - $VIEW_TEXT->configure(qw/-state normal/); - $VIEW_TEXT->delete(qw/1.0 end/); - open(VIEW, "<$widget") or warn "Cannot open demo file $widget: $!"; - { - local $/ = undef; - $VIEW_TEXT->insert('1.0', ); - } - close VIEW; - $VIEW_TEXT->markSet(qw/insert 1.0/); - $VIEW_TEXT->configure(qw/-state disabled/); - -} # end view_widget_code - -__END__ - -=head1 NAME - -zinc-demos - Demonstration of TkZinc widget functionnality - -=head1 SYNOPSYS - - zinc-demos [ directory ] - -=head1 DESCRIPTION - -This script demonstrates the various functions offered by Tk Zinc widget. -This file only contains code to -generate the main window for the application, which invokes individual -demonstrations. The code for the actual demonstrations is contained in -separate ".pl" files in the "zinc_lib" directory, which are autoloaded -by this script as needed. - -widget looks in the directory specified on the command line to load user -contributed demonstrations. If no directory name is specified when widget is -invoked and the environment variable WIDTRIB is defined then demonstrations -are loaded from the WIDTRIB directory. If WIDTRIB is undefined then widget -defaults to the released user contributed directory, "zinc_contrib_lib". - -=head2 History - - # - # Stephen O. Lidie, LUCC, 96/03/11. lusol@Lehigh.EDU - # Stephen O. Lidie, LUCC, 97/01/01. lusol@Lehigh.EDU - # Stephen O. Lidie, LUCC, 97/02/11. lusol@Lehigh.EDU - # Stephen O. Lidie, LUCC, 97/06/07. lusol@Lehigh.EDU - # Update for Tk402.00x. Total revamp: WidgetDemo, Scrolled, released - # composites, -menuitems, qw//, etcetera. Perl 5.004 required. - # Stephen O. Lidie, LUCC, 98/03/10. lusol@Lehigh.EDU - # Update for Tk8. - # Stephen O. Lidie, LUCC, 98/06/26. Stephen.O.Lidie@Lehigh.EDU - # Add Common Dialogs for Tk800.007. - # Stephen.O.Lidie@Lehigh.EDU, 1999/11/29, Lehigh University. - # Demo some "dash patch" changes. - # Stephen.O.Lidie@Lehigh.EDU, 2000/01/11, Lehigh University. - # Update menubar to Tk 8, fix color palette Menubutton demo. - # Stephen.O.Lidie@Lehigh.EDU, 2000/07/06, Lehigh University. - # Remove inswt() from widget and styles.pl to show the proper Perl/Tk - # idiom for inserting Text tags. Various and sundry cleanups. - # Christophe Mertz , 2002/03/06, CENA fr - # adaptation for zinc demos purposes. - -=head1 AUTHOR - -Steve Lidie and slight adaptation by Christophe Mertz - -=head1 SEE ALSO - -The zinc documentation is available as a pdf file refman.pdf and as an html pages refman/index.html - -=cut diff --git a/Perl/export2cpan b/Perl/export2cpan deleted file mode 100755 index 232f42c..0000000 --- a/Perl/export2cpan +++ /dev/null @@ -1,173 +0,0 @@ -#!/usr/bin/perl - -# -# If we want to extract a release right out of the repository -# just pass the release tag as first parameter and the script -# will leave a tarball in the current directory after chewing -# a moment in /tmp. -# the first argument should be a CVS tag looking like cpan_3_2_95 -# or cpan_3_295. The second underscore will be removed for computing the -# - -# In the other case (no parameters) the script supposes we are -# in the Perl subdir of a Tkzinc working directory and it will -# setup zinc-perl for compilation in export2cpan/tk-zinc-. -# The source files are taken from the working directory. This is -# the anticipated behavior when developping/testing or making -# a debian package from the rules file. -# $Id$ - -use strict; - -my $ZINC_PREFIX = 'tk-zinc'; -my $DEFAULT_SERVER = 'liszt.pii.ath.cena.fr'; -my $TMP = '/tmp/forCPAN'; - -# computing major, minor and patchlevel from var defined in ../configure.in -sub version4cpan { - my $configure_in = "../configure.in"; - - open(FD, "<$configure_in") or die "Could not open file $configure_in"; - - my ($major, $minor, $patchlevel); - while () { - if (/^MAJOR_VERSION=(\d+)/) - { - $major = $1; - } - elsif (/^MINOR_VERSION=(\d+)/) - { - $minor = $1; - } - elsif (/^PATCHLEVEL=(\d+)/) - { - $patchlevel = $1; - } - } - - close (FD); - - return "$major.$minor$patchlevel"; -} - -my $VERSION; -my $FROM_CVS = (scalar(@ARGV) != 0); -my $DIR_FROM_CVS; -my $CWD; -chomp($CWD = `pwd`); -# -# See if parameters are given (there should be a cvs tag -# and may be the repository machine). -# -if ($FROM_CVS) { - my $tag_version; - my $cvstag = $ARGV[0]; - my $server = $DEFAULT_SERVER; - if (scalar(@ARGV) == 2) { - $server = $ARGV[1]; - } - print "Building a CPAN release tarball from tag $cvstag.\n"; - $cvstag =~ /^.*?([\d_]+)$/; - my $tag_version = $1; - if ($tag_version =~ /(\d+)_(\d+)_(\d+)/) { - $tag_version = "$1_$2$3"; - } - $VERSION = version4cpan; # version computed from the source directory - $DIR_FROM_CVS = "$ZINC_PREFIX-$VERSION"; - system("rm -rf $TMP"); - system ("mkdir $TMP"); - chdir("$TMP"); - # the following command always fail with cvs 1.11.1p1 !! - # my $command = "cd $TMP; cvs -d $server:/pii/repository export -r $cvstag -d $DIR_FROM_CVS Tkzinc"; - my $command = "cd $TMP; cvs -d /pii/repository export -r $cvstag -d $DIR_FROM_CVS Tkzinc"; - print "$command\n"; - my $error = system($command); - die "CVS extraction did not succeed" if $error; - chdir("$DIR_FROM_CVS/Perl"); - my $EXTRACTED_VERSION = version4cpan; # version gotten from the tagged CVS files - if ($EXTRACTED_VERSION ne $VERSION) { - print "Oops! the tag version '$tag_version' does not match the version '$VERSION' in the sources, aborting\n"; - exit(1); - } - system ("cd $TMP/$DIR_FROM_CVS; ./configure"); -} -else { - $VERSION = version4cpan; - print "cd ..; ./configure\n"; - system ("cd ..; ./configure"); # for creating Zinc.pm and Makefile.pl from xxx.in files -} - -print "VERSION $VERSION\n"; - -# using rsync if available rather than cp -my $CP = 'cp -r'; -my $CPonlyIfDifferent = 'cp -r'; -my $RSYNC = 0; -if (-x '/usr/bin/rsync') { - $CP = '/usr/bin/rsync -rp'; # the --delete option has been removed to avoid deleting Makefile in demos - $CPonlyIfDifferent = '/usr/bin/rsync -rc'; -# print "\$CP = '$CP'\n"; - $RSYNC = 1; -} elsif (-x '/usr/local/bin/rsync') { - $CP = '/usr/local/bin/rsync -rp'; # the --delete option has been removed to avoid deleting Makefile in demos - $CPonlyIfDifferent = '/usr/local/bin/rsync -rc'; -# print "\$CP = '$CP'\n"; - $RSYNC = 1; -} - -my $EXPORT_DIR = '../export2cpan'; -my $VERSION_DIR = "$ZINC_PREFIX-$VERSION"; - -if (-d "$EXPORT_DIR/$VERSION_DIR" and !$RSYNC) { - system("rm -rf $EXPORT_DIR/$VERSION_DIR"); -} - -if (! -d $EXPORT_DIR) { - mkdir($EXPORT_DIR); -} -if (! -d "$EXPORT_DIR/$VERSION_DIR") { - mkdir("$EXPORT_DIR/$VERSION_DIR"); -} -symlink ("$EXPORT_DIR/$VERSION_DIR", "$EXPORT_DIR/$ZINC_PREFIX"); - -my @files=('t', 'Zinc.xs', 'demos', 'README', 'Zinc'); - - -foreach my $f (@files) { - system("$CP $f $EXPORT_DIR/$VERSION_DIR"); -} - - -system("$CP Zinc.pm $EXPORT_DIR/$VERSION_DIR"); -system("$CP Makefile.PL $EXPORT_DIR/$VERSION_DIR"); -system("$CP ../libtess/*.c $EXPORT_DIR/$VERSION_DIR"); -system("$CP ../libtess/*.h $EXPORT_DIR/$VERSION_DIR"); -system("$CP ../generic/*.c $EXPORT_DIR/$VERSION_DIR"); -system("$CP ../generic/*.h $EXPORT_DIR/$VERSION_DIR"); -system("$CP ../win/*.c $EXPORT_DIR/$VERSION_DIR"); - - -# -# If working for an exported copy, build a tarball in the -# current dir. -# -if ($FROM_CVS) { - chdir("$EXPORT_DIR/$VERSION_DIR"); - - # - # Remove the .cvsignore files - system('find . -name .cvsignore | xargs rm -f'); - - # - # Create the MANIFEST file - use ExtUtils::Manifest qw( mkmanifest ); - $ExtUtils::Manifest::Quiet = 1; - &mkmanifest(); - - chdir('..'); - - system("tar zcf $TMP/$ZINC_PREFIX-$VERSION.tar.gz $VERSION_DIR"); - chdir($CWD); - print "The tarball is in $TMP/$ZINC_PREFIX-$VERSION.tar.gz\n"; - print "You may want to clean up after testing in $TMP/$DIR_FROM_CVS\n"; -} diff --git a/Perl/t/.cvsignore b/Perl/t/.cvsignore deleted file mode 100644 index 532f21c..0000000 --- a/Perl/t/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -*.log -*.log.prev diff --git a/Perl/t/AnimatedGradient.t b/Perl/t/AnimatedGradient.t deleted file mode 100644 index e65f9a3..0000000 --- a/Perl/t/AnimatedGradient.t +++ /dev/null @@ -1,175 +0,0 @@ -#!/usr/bin/perl -w - -# -# $Id: AnimatedGradient.t,v 1.1 2004-09-20 20:07:06 mertz Exp $ -# Author: Christophe Mertz mertz@intuilab.com -# - -# this test mainly does funny effects when openGL is on - - -# testing all the import - -BEGIN { - if (!eval q{ -# use Test::More qw(no_plan); - use Test::More tests => 18; - 1; - }) { - print "# tests only work properly with installed Test::More module\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - use Tk::Zinc; - 1; - }) { - print "unable to load Tk::Zinc"; - print "1..1\n"; - print "ok 1\n"; - exit; - } -} - -use strict; -my $mw = MainWindow->new(); -my $zinc = $mw->Zinc(-width => 200, -height => 200, -backcolor => "white", - -render => 1)->pack; - -like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created"); - -$zinc->add('text', 1, -position => [10,5], -text => -"the gradient fills a rectangle -which is clipped by the curve -made of two circles...\n"x5); - - -my $circle1 = $zinc->add('arc', 1, [20,20,180,180]); -my $circle2 = $zinc->add('arc', 1, [70,70,130,130]); - -my $curve = $zinc->add('curve', 1, [], - -fillcolor => 'red', -filled => 1, -linewidth => 1); -$zinc->contour($curve, 'add', 1, $circle1); -$zinc->contour($curve, 'add', -1, $circle2); - -$zinc->remove($circle1); -$zinc->remove($circle2); - -my $gradient; -for (1..4) { - for (my $i = 0; $i <=360; $i++) { - $gradient = "=axial $i | red | white 50 | blue"; - $zinc->itemconfigure($curve, -fillcolor => $gradient); - $zinc->update; - } -} -pass("turning gradient one side"); - -for (1..4) { - for (1..100) { - $zinc->translate($curve,0.5,0.5); - $zinc->update; - } - for (1..800) { - $zinc->rotate($curve, 3.14159/400, 100,100); - $zinc->update; - } - for (1..100) { - $zinc->translate($curve,0.5,0.5); - $zinc->update; - } - - for (1..400) { - $zinc->translate($curve,-0.5,-0.5); - $zinc->update; - } - for (1..200) { - $zinc->translate($curve,0.5,0.5); - $zinc->update; - } - pass ("shaking the circle around"); -} - -for (1..4) { - for (my $i = 359; $i > 0; $i--) { - $gradient = "=axial $i | red | white 50 | blue"; - $zinc->itemconfigure($curve, -fillcolor => $gradient); - $zinc->update; - } -} -pass("turning gradient the other side"); - - -my $gr = $zinc->add('group', 1); -my $rect = $zinc->add('rectangle', $gr, [0,-480,200,180], -filled => 1, - -fillcolor => "=axial 90 |blue|white 10|red 20|white 30|blue 40|white 50|red 60|white 70|blue 80|white 90|red"); - -$zinc->chggroup($curve, $gr); -$zinc->itemconfigure($curve, -visible => 0); - -$zinc->itemconfigure($gr, -clip => $curve); - - -pass("displaying a translated rectangle filled with froggy colors and clipped by two circles"); -for (1..2) { - for (my $i = 0; $i<500 ; $i++) { - $zinc->translate($rect, 0,1); - $zinc->update; - } - for (my $i = 0; $i<500 ; $i++) { - $zinc->translate($rect, 0,-1); - $zinc->update; - } - pass ("a thousand translation"); -} - -$zinc->translate($rect, 0,250); - - -for (1..1000) { - $zinc->scale($rect, 1, 0.998, 100,100); - $zinc->update; -} -pass("a thousand scaling down"); - - -for (1..360) { - $zinc->rotate($rect, 3.14159/180, 100,100); - $zinc->update; -} -pass("360 rotation of 1°"); - - -for (1..360) { - $zinc->rotate($rect, -3.14159/180, 100,100); - $zinc->update; -} -pass("360 rotation of 1°"); - - -for (1..360) { - $zinc->rotate($rect, -3.14159/180, 100,100); - $zinc->update; -} - - -for (1..1000) { - $zinc->scale($rect, 1, 1/0.998, 100,100); - $zinc->update; -} -pass("a thousand scaling up"); - - - -for (1..4) { - for my $i (0..200) { - $zinc->itemconfigure($gr, -alpha => (200-$i)/2); - $zinc->update; - } - for my $i (0..200) { - $zinc->itemconfigure($gr, -alpha => $i/2); - $zinc->update; - } - pass("fade out/in in 400 steps"); -} diff --git a/Perl/t/Bbox.t b/Perl/t/Bbox.t deleted file mode 100644 index 5840fc3..0000000 --- a/Perl/t/Bbox.t +++ /dev/null @@ -1,242 +0,0 @@ -#!/usr/bin/perl -w - -# -# $Id: Bbox.t,v 1.7 2004-11-16 20:46:14 mertz Exp $ -# Author: Christophe Mertz -# - -# testing all the import - -BEGIN { - if (!eval q{ - use Test::More tests => 12; - 1; - }) { - print "# tests only work properly with installed Test::More module\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - use Tk::Zinc; - use Tk::Font; - 1; - }) { - print "unable to load Tk::Zinc"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - MainWindow->new(); - 1; - }) { - print "# tests only work properly when it is possible to create a mainwindow in your env\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } -} - - -$mw = MainWindow->new(); -$zinc = $mw->Zinc(-width => 400, -height => 400)->pack; -like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created"); - -my $coords = [ [10,10], [40, 40] ]; - - -my $font = $zinc->fontCreate('font20pixels', -size => -20); -#my @metrics = $zinc->fontMetrics('font20pixels'); -#print "metrics = @metrics\n"; -my $linespace = $zinc->fontMetrics('font20pixels', -linespace); - -my $txt1 = $zinc->add('text', 1, - -font => 'font20pixels', - -alignment => 'center', - #-text => 'text', # an empty text - -position => [30,25], - ); -#print "bbox=(", join(',', $zinc->bbox($txt1)),")\n"; - -# from v3.30 the bbox of an empty text is () -ok(&similarFlatArray ([$zinc->bbox($txt1)], - [], - [], - ), - "bbox of empty text"); - -my $width = $zinc->fontMeasure('font20pixels', 'dummy'); -#print "width = $width\n"; -my $txt2 = $zinc->add('text', 1, - -font => 'font20pixels', - -alignment => 'left', - -text => 'dummy', - -position => [200,100], - ); -# print "bbox=(", join(',', $zinc->bbox($txt2)),")\n"; - -ok(&similarFlatArray ([$zinc->bbox($txt2)], - [200,100, 200+$width, 100+$linespace], - [4,4, 4,4 ], - ), - "bbox of 'dummy' text"); - -my $txt3 = $zinc->add('text', 1, - -font => 'font20pixels', - -alignment => 'center', - -text => 'dummy', - -position => [200,200], - ); -# print "bbox=(", join(',', $zinc->bbox($txt3)),")\n"; - -ok(&similarFlatArray ([$zinc->bbox($txt3)], - [200,200, 200+$width, 200+$linespace], - [4,4, 4,4 ], - ), - "bbox of 'dummy' aligned-centered text"); - -my $txt4 = $zinc->add('text', 1, - -font => 'font20pixels', - -anchor => 'center', - -text => 'dummy', - -position => [200,100], - ); -# print "bbox=(", join(',', $zinc->bbox($txt4)),")\n"; - -ok(&similarFlatArray ([$zinc->bbox($txt4)], - [200-$width/2,100-$linespace/2, 200+$width/2, 100+$linespace/2], - [4,4, 4,4 ], - ), - "bbox of 'dummy' centered text"); - - -### testing bbox of fields or labels of track/waypoint and tabular items -my $track = $zinc->add('track', 1, 4, -position => [56, 78]); -# print "bbox11=(", $bbox,")\n"; - -is($zinc->bbox(-label, $track), (), - "bbox of a track label without labelformat is ()"); - -my $bbox = $zinc->bbox(-field, 0, $track); -#print "bbox22=(", $bbox,")\n"; - -is( $bbox, undef, "bbox of a track field without labelformat is undef"); - - -$zinc->itemconfigure($track, -labelformat => 'x20x18+0+0'); -#print "bbox=(", join(',', $zinc->bbox(-label, $track)),")\n"; - -$bbox = eval { $zinc->bbox(-field, 4, $track) } ; -#print "bbox=(", $bbox,")\n"; - -is( $bbox, (), - "bbox of a track field which field is out of bound is undef"); - -my $wpt = $zinc->add('waypoint', 1, 0, -position => [561, 781]); -#print "wpt bbox=(", join(',', $zinc->bbox($wpt)),")\n"; -ok(&similarFlatArray ([ $zinc->bbox($wpt) ], - [ 561,781, 561,781], - [4,4, 4,4], - ), - "coords of a waypoint without label"); - - -my $tab = $zinc->add('tabular', 1, 1, -position => [61, 81]); -is_deeply([ $zinc->bbox($tab) ], - [ ], - "bbox of a tabular without labelformat"); - -#print "tab bbox=(", join(',', $zinc->bbox(-label, $tab)),")\n"; -is_deeply([ $zinc->bbox(-label, $tab) ], - [ ], - "bbox of a tabular without labelformat"); - -#print "tab bbox=(", join(',', $zinc->bbox(-field, 0, $tab)),")\n"; -is_deeply([ $zinc->bbox(-field, 0, $tab) ], - [ ], - "bbox of a tabular field without labelformat"); - - -# $zinc->itemconfigure($tab, -labelformat => 'x20x18+0+0'); -# is_deeply([ $zinc->coords($tab) ], -# [ 61,81 ], -# "coords of a tabular with a labelformat"); - - - - -sub similarPoints { - my ($ref1, $ref2)= @_; - diag ("waiting a reference for \$ref1" . ref ($ref1)), return 0 unless ref ($ref1) eq 'ARRAY'; - diag ("waiting a reference for \$ref2"), return 0 unless ref ($ref2) eq 'ARRAY'; - - my @array1 = @{$ref1}; - my @array2 = @{$ref2}; - - diag ("arrays for \$ref1 and \$ref2 are not of same length"), return 0 - unless scalar @array1 == @array2; - - for my $i (0.. $#array1) { - my $pt1 = $array1[$i]; - my $pt2 = $array2[$i]; - diag ("waiting a reference to a point in elt $i \$ref1"), return 0 - unless ref $pt1 eq 'ARRAY'; - my (@pt1) = @{$pt1}; - diag ("waiting a reference to a point (x,y) in elt $i \$ref1"), return 0 - unless scalar @pt1 == 2 and &numerical($pt1[0]) and &numerical($pt1[1]) ; - - diag ("waiting a reference to a point in elt $i \$ref1"), return 0 - unless ref $pt2 eq 'ARRAY'; - my (@pt2) = @{$pt2}; - diag ("waiting a reference to a point (x,y) in elt $i \$ref2"), return 0 - unless scalar @pt2 == 2 and &numerical($pt2[0]) and &numerical($pt2[1]) ; - - diag ("delta > 0.001 between x of pt$i"), return 0 if abs($pt1[0]-$pt2[0]) > 0.001; - diag ("delta > 0.001 between y of pt$i"), return 0 if abs($pt1[1]-$pt2[1]) > 0.001; - } - return 1; -} - -## ref1 is the obtained array -## ref2 is the expected array -sub similarFlatArray { - my ($ref1, $ref2, $deltaref)= @_; - diag ("waiting a reference for \$ref1"), return 0 unless ref ($ref1) eq 'ARRAY'; - diag ("waiting a reference for \$ref2"), return 0 unless ref ($ref2) eq 'ARRAY'; - diag ("waiting a reference for \$deltaref"), return 0 unless ref ($deltaref) eq 'ARRAY'; - - my @array1 = @{$ref1}; - my @array2 = @{$ref2}; - my @deltaarray = @{$deltaref}; - diag ("arrays obtained, expected and deltas are not of same length,".$#array1.",".$#array2.",".$#deltaarray), return 0 - unless ($#array1 == $#array2) and ($#array2 == $#deltaarray); - for my $i (0.. $#array1) { - my $a = $array1[$i]; - my $b = $array2[$i]; - my $delta = $deltaarray[$i]; - diag ("waiting a numeric value for elt $i of obtained array"), return 0 - unless &numerical($a); - diag ("waiting a numeric value for elt $i of expected array"), return 0 - unless &numerical($b); - diag ("waiting a numeric value for elt $i of deltas array"), return 0 - unless &numerical($delta); - - diag ("delta > $delta between elt $i of obtained array ($a) and expected array ($b)"), return 0 - if (abs($a-$b) > $delta) ; - } - return 1; -} - - -sub numerical { - my ($v) = @_; - return 0 unless defined $v; - ### this really works!! - return $v eq $v*1; - } - - -diag("############## bbox test"); - - diff --git a/Perl/t/Coords.t b/Perl/t/Coords.t deleted file mode 100644 index b8c4662..0000000 --- a/Perl/t/Coords.t +++ /dev/null @@ -1,151 +0,0 @@ -#!/usr/bin/perl -w - -# -# $Id: Coords.t,v 1.6 2004-05-24 19:56:23 mertz Exp $ -# Author: Christophe Mertz -# - -# testing all the import - -BEGIN { - if (!eval q{ -# use Test::More qw(no_plan); - use Test::More tests => 21; - 1; - }) { - print "# tests only work properly with installed Test::More module\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - use Tk::Zinc; - 1; - }) { - print "unable to load Tk::Zinc"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - MainWindow->new(); - 1; - }) { - print "# tests only work properly when it is possible to create a mainwindow in your env\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } -} - - -$mw = MainWindow->new(); -$zinc = $mw->Zinc(-width => 100, -height => 100); - -like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created"); - -my $rect = $zinc->add('rectangle', 1, [10,20,40,50]); - - -is_deeply([ $zinc->coords($rect) ], - [ [10,20], [40, 50] ], - "coords are list of arrays"); - -is_deeply([ $zinc->coords($rect,0) ], - [ [10,20], [40, 50] ], - "coords of first contour is a list of arrays"); - -is_deeply([ $zinc->coords($rect,0,0) ], - [ 10,20 ], - "coords of one point of a contour is a list of two numbers"); - -is_deeply([ $zinc->coords($rect,0,1) ], - [ 40,50 ], - "coords of one point of a contour is a list of two numbers"); - -my $curve = $zinc->add('curve', 1, [ [10,20] ,[40,50,'c'], [90,10,'c'], [30,60] ]); - -is_deeply([ $zinc->coords($curve) ], - [ [10,20] ,[40,50,'c'], [90,10,'c'], [30,60] ], - "coords of a curve is a list of arrays"); - -is_deeply([ $zinc->coords($curve,0) ], - [ [10,20] ,[40,50,'c'], [90,10,'c'], [30,60] ], - "coords of contour 0 of a curve is a list of arrays"); - -is_deeply([ $zinc->coords($curve,0,0) ], - [ 10,20 ], - "coords of first point of contour 0 of a curve is list of two numbers"); - -is_deeply([ $zinc->coords($curve,0,1) ], - [ 40,50,'c' ], - "coords of a control point of a curve contour is list of three elements"); - -my $text = $zinc->add('text', 1, -position => [10,20], -text => 'test'); - -is_deeply([ $zinc->coords($text) ], - [ 10,20 ], - "coords of a text"); - -is_deeply([ $zinc->coords($text,0) ], - [ 10,20 ], - "coords of text contour"); - -is_deeply([ $zinc->coords($text,0,0) ], - [ 10,20 ], - "coords of text contour first point"); - - -my $group = $zinc->add('group', 1); - -is_deeply([ $zinc->coords($group) ], - [ 0,0 ], - "coords of a empty group, not moved"); - -$zinc->translate($group, 23, 45); -#my @coords = @{$zinc->coords($group)}[0]; -#print "coords = @coords", $coords[0][0], $coords[0][1], "\n"; -is_deeply([ $zinc->coords($group) ], - [ 23,45 ], - "coords of a empty group, translated"); - - -my $track = $zinc->add('track', 1, 0, -position => [56, 78]); -is_deeply([ $zinc->coords($track) ], - [ 56,78 ], - "coords of a track"); - -my $wpt = $zinc->add('waypoint', 1, 0, -position => [561, 781]); -is_deeply([ $zinc->coords($wpt) ], - [ 561,781 ], - "coords of a waypoint"); - -my $tab = $zinc->add('tabular', 1, 1, -position => [61, 81]); -is_deeply([ $zinc->coords($tab) ], - [ 61,81 ], - "coords of a empty tabular"); -$zinc->itemconfigure($tab, -labelformat => 'x20x18+0+0'); -is_deeply([ $zinc->coords($tab) ], - [ 61,81 ], - "coords of a tabular with a labelformat"); - - -my $arc = $zinc->add('arc', 1, [13,31, 42,24]); -is_deeply([ $zinc->coords($arc) ], - [ [13,31], [42,24] ], - "coords of an arc"); - -my $tri = $zinc->add('triangles', 1, [ [10,20], [30,40], [50,60], [70,80], [90,99] ]); -is_deeply([ $zinc->coords($tri) ], - [ [10,20], [30,40], [50,60], [70,80], [90,99] ], - "coords of an triangle"); - -my $photoMickey = $zinc->Photo('mickey.gif', -file => Tk->findINC("demos/images/mickey.gif")); -my $icon = $zinc->add('icon', 1, -position => [20,100], -image => $photoMickey); -is_deeply([ $zinc->coords($icon) ], - [ 20,100 ], - "coords of an icon"); - -diag("############## coords test"); - - diff --git a/Perl/t/Images.t b/Perl/t/Images.t deleted file mode 100644 index 99111c5..0000000 --- a/Perl/t/Images.t +++ /dev/null @@ -1,212 +0,0 @@ -#!/usr/bin/perl -w - -# -# $Id: Images.t,v 1.5 2004-05-12 12:33:33 mertz Exp $ -# Author: Christophe Mertz -# - -# testing all the -tile, -image, -mask, -fillpattern, -linepattern widget and items options - -# this script can be used with an optionnal argument, an integer giving -# the delay in seconds during which the graphic updates will be displayed -# this is usefull for visual inspection! - -BEGIN { - if (!eval q{ -# use Test::More qw(no_plan); - use Test::More tests => 36; - 1; - }) { - print "# tests only work properly with installed Test::More module\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - use Tk::Zinc; - 1; - }) { - print "unable to load Tk::Zinc"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - $mw = MainWindow->new(); - 1; - }) { - print "# tests only work properly when it is possible to create a mainwindow in your env\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } -} - - -$zinc = $mw->Zinc(-render => 0, - -width => 400, -height => 400)->pack; - -like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created"); - -#### creating different images, bitmaps and pixmaps... -my $photoMickey = $zinc->Photo('mickey.gif', -file => Tk->findINC("demos/images/mickey.gif")); -like ($photoMickey, qr/^Tk::Photo=HASH/ , "creating a Tk::Photo with a .gif"); - -my $bitmap = $zinc->Bitmap('file.xbm', -file => Tk->findINC("file.xbm")); -like ($bitmap, qr/^Tk::Bitmap=HASH/ , "creating a Tk::Bitmap with a .xbm"); - -my $xpm = $zinc->Photo('QuitPB.xpm', -file => Tk->findINC("demos/images/QuitPB.xpm")); -like ($xpm, qr/^Tk::Photo=HASH/ , "creating a Tk::Photo with a .xpm"); - -#### tiling Tk::Zinc -$zinc->configure(-tile => $xpm); -if ($Tk::VERSION < 804) { - is ($zinc->cget(-tile), "QuitPB.xpm", "verifying Tk::Zinc -tile option value"); -} else { - is ($zinc->cget(-tile), $xpm, "verifying Tk::Zinc -tile option value"); -} - -&wait ("-tile of Tk::Zinc with QuitPB.xpm"); - -$zinc->configure(-tile => $photoMickey); -if ($Tk::VERSION < 804) { - is ($zinc->cget(-tile), "mickey.gif", "verifying Tk::Zinc -tile option value"); -} else { - is ($zinc->cget(-tile), $photoMickey, "verifying Tk::Zinc -tile option value"); -} -&wait ("-tile of Tk::Zinc with mickey.gif"); - -# modifying the Tk::Photo to see if the Tk::Zinc -tile changes -$photoMickey->read( Tk->findINC("demos/images/earth.gif") ); -&wait ("-tile of Tk::Zinc should display the earth VISUAL INSPECTION!"); sleep 1; -# going back to the "real" mickey -$photoMickey->read( Tk->findINC("demos/images/mickey.gif") ); -&wait ("-tile of Tk::Zinc should display mickey again VISUAL INSPECTION!"); sleep 1; - -$zinc->configure(-tile => ""); -if ($Tk::VERSION < 804) { - is ($zinc->cget(-tile), "", "removing Tk::Zinc -tile"); -} else { - is ($zinc->cget(-tile), undef, "removing Tk::Zinc -tile"); -} -&wait ("-tile of Tk::Zinc with nothing"); - - - -#### rectangle item -my $rect1 = $zinc->add('rectangle', 1, [10,10,190,190], -filled => 1); - - -$zinc->itemconfigure($rect1, -tile => $xpm); -is ($zinc->itemcget($rect1, -tile), "QuitPB.xpm", "verifying rectangle -tile option value"); -&wait ("-tile of rectangle with QuitPB.xpm"); - -$zinc->itemconfigure($rect1, -tile => $photoMickey); -is ($zinc->itemcget($rect1, -tile), "mickey.gif", "verifying rectangle -tile option value"); -&wait ("-tile of rectangle with mickey"); - -# modifying the Tk::Photo to see if the rectangle -tile changes -$photoMickey->read( Tk->findINC("demos/images/earth.gif") ); -&wait ("-tile of rectangle should display the earth VISUAL INSPECTION!"); sleep 1; -# going back to the "real" mickey -$photoMickey->read( Tk->findINC("demos/images/mickey.gif") ); -&wait ("-tile of rectangle should display mickey again VISUAL INSPECTION!"); sleep 1; - - -$zinc->itemconfigure($rect1, -tile => ""); -is ($zinc->itemcget($rect1, -tile), "", "removing rectangle -tile"); -&wait ("-tile of rectangle with nothing"); - -TODO: { - local $TODO = "because it makes Tk::Zinc dying" if 1; - - # the next line makes Tk::Zinc (v3.29x) dying... so I comment it out the 3 next lines - # $zinc->itemconfigure($rect1, -fillpattern => $bitmap); - # is ($zinc->itemcget($rect1, -fillpattern), $bitmap, "verifying rectangle -fillpattern option value as a Tk::Bitmap"); - # &wait ("displaying a rectangle with -fillpattern as a Tk::Bitmap"); -} - -$zinc->itemconfigure($rect1, -fillpattern => 'AlphaStipple3'); -is ($zinc->itemcget($rect1, -fillpattern), 'AlphaStipple3', "verifying rectangle -fillpattern option value"); -&wait ("-fillpattern of rectangle with 'AlphaStipple3'"); - -$zinc->itemconfigure($rect1, -fillpattern => ""); -is ($zinc->itemcget($rect1, -fillpattern), "", "removing rectangle -fillpattern"); -&wait ("-fillpattern of rectangle with nothing"); - - -$zinc->itemconfigure($rect1, -filled => 0,-linepattern => 'AlphaStipple3', -linecolor => "red"); -is ($zinc->itemcget($rect1, -linepattern), 'AlphaStipple3', "verifying rectangle -linepattern option value"); -&wait ("-linepattern of rectangle with 'AlphaStipple3'"); - -$zinc->itemconfigure($rect1, -linepattern => ""); -is ($zinc->itemcget($rect1, -linepattern), "", "removing rectangle -linepattern"); -&wait ("-linepattern of rectangle with nothing"); - -$zinc->remove($rect1); - -##### icon item -my $icon1 = $zinc->add('icon', 1, -position => [20,100], -image => $photoMickey); -&wait ("displaying an icon"); - -$zinc->remove($icon1); - -my $icon2 = $zinc->add('icon', 1, -position => [40,100]); - -SKIP: { - skip "with Tk::Zinc < 3.295", 4 if ($Tk::Zinc::VERSION < 3.295); - - $zinc->itemconfigure($icon2, -image => $bitmap); - - &wait ("displaying an icon with -image as a Tk::Bitmap"); - is ($zinc->itemcget($icon2, -image), 'file.xbm', "verifying icon -image option value as file.xbm"); - $zinc->itemconfigure($icon2, -image => ""); - - $zinc->itemconfigure($icon2, -image => '@'.Tk->findINC("openfile.xbm")); - is ($zinc->itemcget($icon2, -image), '@'.Tk->findINC("openfile.xbm"),"verifying icon -image option value as @/path/openfile.xbm"); - &wait ("displaying an icon with -image as a \@filename.xbm"); -} -$zinc->remove($icon2); - -my $icon3 = $zinc->add('icon', 1, -position => [60,100], -mask => '@'.Tk->findINC("openfolder.xbm"), - -color => "red"); -is ($zinc->itemcget($icon3, -mask), '@'.Tk->findINC("openfolder.xbm"),"verifying icon -mask option value as \@/path/openfolder.xbm"); -&wait ("displaying an icon with -mask as a \@filename.xbm"); - -$zinc->itemconfigure($icon3, -image => ""); -is ($zinc->itemcget($icon3, -image), "", "removing icon -image"); - -TODO: { - local $TODO = "because it makes Tk::Zinc dying" if 1; - - # the next line makes Tk::Zinc (v3.29x) dying... so I comment it out the 3 next lines - # $zinc->itemconfigure($icon3, -mask => $bitmap); - # is ($zinc->itemcget($icon3, -mask), $bitmap, "verifying icon -mask option value as a Tk::Bitmap"); - # &wait ("displaying an icon with -mask as a Tk::Bitmap"); -} - -$zinc->remove($icon3); - -# We should also test that changing the content of a Tk::Photo should change the display of an icon - - - -sub wait { - $zinc->update; - ok (1, $_[0]); - - my $delay = $ARGV[0]; - if (defined $delay) { - $zinc->update; - if ($delay =~ /^\d+$/) { - sleep $delay; - } else { - sleep 1; - } - } - -} - - - -diag("############## Images test"); diff --git a/Perl/t/Import.t b/Perl/t/Import.t deleted file mode 100644 index a051e29..0000000 --- a/Perl/t/Import.t +++ /dev/null @@ -1,31 +0,0 @@ -#!/usr/bin/perl -w - -# -# $Id: Import.t,v 1.2 2004-04-02 12:01:49 mertz Exp $ -# Author: Christophe Mertz -# - -# testing all the import - -BEGIN { - if (!eval q{ -# use Test::More qw(no_plan); - use Test::More tests => 6; - 1; - }) { - print "# tests only work properly with installed Test::More module\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } -} - -require_ok( 'Tk::Zinc' ); -require_ok( 'Tk::Zinc::Debug' ); -require_ok( 'Tk::Zinc::Trace' ); -# require_ok( 'Tk::Zinc::TraceErrors' ); # incompatible with the previous one -# we do not test the previous, as it should be equivalent! -require_ok( 'Tk::Zinc::Graphics' ); -require_ok( 'Tk::Zinc::Logo' ); -require_ok( 'Tk::Zinc::Text' ); -diag("############## all imports"); diff --git a/Perl/t/PreviousKnownBugs.t b/Perl/t/PreviousKnownBugs.t deleted file mode 100644 index 934cdf7..0000000 --- a/Perl/t/PreviousKnownBugs.t +++ /dev/null @@ -1,61 +0,0 @@ -#!/usr/bin/perl -w - -# -# $Id: PreviousKnownBugs.t,v 1.3 2004-04-02 12:01:49 mertz Exp $ -# Author: Christophe Mertz -# - -# testing all the import - -BEGIN { - if (!eval q{ -# use Test::More qw(no_plan); - use Test::More tests => 2; - 1; - }) { - print "# tests only work properly with installed Test::More module\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - use Tk::Zinc; - 1; - }) { - print "unable to load Tk::Zinc"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - MainWindow->new(); - 1; - }) { - print "# tests only work properly when it is possible to create a mainwindow in your env\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } -} - -#use Tk::Zinc; - -$mw = MainWindow->new(); -$zinc = $mw->Zinc(-width => 100, -height => 100); - -like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created"); - -# following bug detected by A. Lemort -my $curve = $zinc->add('curve', 1, [[0, 0], [0, 100, 'c'], [100,100, 'c'], [100, 0]]) ; -$zinc->coords($curve, [[500,0], [500, 100], [600, 100], [600, 0]]); - -my @coords = $zinc->coords($curve,0); - - -is_deeply([ @coords ], - [ [500,0], [500, 100], [600, 100], [600, 0] ], - "lemort bug 17 sept 2003 v3.2.94; testing correct value"); - - - -diag("############## all known bugs"); diff --git a/Perl/t/Test/Builder.pm b/Perl/t/Test/Builder.pm deleted file mode 100644 index 6f3edd8..0000000 --- a/Perl/t/Test/Builder.pm +++ /dev/null @@ -1,1408 +0,0 @@ -package Test::Builder; - -use 5.004; - -# $^C was only introduced in 5.005-ish. We do this to prevent -# use of uninitialized value warnings in older perls. -$^C ||= 0; - -use strict; -use vars qw($VERSION $CLASS); -$VERSION = '0.17'; -$CLASS = __PACKAGE__; - -my $IsVMS = $^O eq 'VMS'; - -# Make Test::Builder thread-safe for ithreads. -BEGIN { - use Config; - if( $] >= 5.008 && $Config{useithreads} ) { - require threads; - require threads::shared; - threads::shared->import; - } - else { - *share = sub { 0 }; - *lock = sub { 0 }; - } -} - -use vars qw($Level); -my($Test_Died) = 0; -my($Have_Plan) = 0; -my $Original_Pid = $$; -my $Curr_Test = 0; share($Curr_Test); -my @Test_Results = (); share(@Test_Results); -my @Test_Details = (); share(@Test_Details); - - -=head1 NAME - -Test::Builder - Backend for building test libraries - -=head1 SYNOPSIS - - package My::Test::Module; - use Test::Builder; - require Exporter; - @ISA = qw(Exporter); - @EXPORT = qw(ok); - - my $Test = Test::Builder->new; - $Test->output('my_logfile'); - - sub import { - my($self) = shift; - my $pack = caller; - - $Test->exported_to($pack); - $Test->plan(@_); - - $self->export_to_level(1, $self, 'ok'); - } - - sub ok { - my($test, $name) = @_; - - $Test->ok($test, $name); - } - - -=head1 DESCRIPTION - -Test::Simple and Test::More have proven to be popular testing modules, -but they're not always flexible enough. Test::Builder provides the a -building block upon which to write your own test libraries I. - -=head2 Construction - -=over 4 - -=item B - - my $Test = Test::Builder->new; - -Returns a Test::Builder object representing the current state of the -test. - -Since you only run one test per program, there is B -Test::Builder object. No matter how many times you call new(), you're -getting the same object. (This is called a singleton). - -=cut - -my $Test; -sub new { - my($class) = shift; - $Test ||= bless ['Move along, nothing to see here'], $class; - return $Test; -} - -=back - -=head2 Setting up tests - -These methods are for setting up tests and declaring how many there -are. You usually only want to call one of these methods. - -=over 4 - -=item B - - my $pack = $Test->exported_to; - $Test->exported_to($pack); - -Tells Test::Builder what package you exported your functions to. -This is important for getting TODO tests right. - -=cut - -my $Exported_To; -sub exported_to { - my($self, $pack) = @_; - - if( defined $pack ) { - $Exported_To = $pack; - } - return $Exported_To; -} - -=item B - - $Test->plan('no_plan'); - $Test->plan( skip_all => $reason ); - $Test->plan( tests => $num_tests ); - -A convenient way to set up your tests. Call this and Test::Builder -will print the appropriate headers and take the appropriate actions. - -If you call plan(), don't call any of the other methods below. - -=cut - -sub plan { - my($self, $cmd, $arg) = @_; - - return unless $cmd; - - if( $Have_Plan ) { - die sprintf "You tried to plan twice! Second plan at %s line %d\n", - ($self->caller)[1,2]; - } - - if( $cmd eq 'no_plan' ) { - $self->no_plan; - } - elsif( $cmd eq 'skip_all' ) { - return $self->skip_all($arg); - } - elsif( $cmd eq 'tests' ) { - if( $arg ) { - return $self->expected_tests($arg); - } - elsif( !defined $arg ) { - die "Got an undefined number of tests. Looks like you tried to ". - "say how many tests you plan to run but made a mistake.\n"; - } - elsif( !$arg ) { - die "You said to run 0 tests! You've got to run something.\n"; - } - } - else { - require Carp; - my @args = grep { defined } ($cmd, $arg); - Carp::croak("plan() doesn't understand @args"); - } - - return 1; -} - -=item B - - my $max = $Test->expected_tests; - $Test->expected_tests($max); - -Gets/sets the # of tests we expect this test to run and prints out -the appropriate headers. - -=cut - -my $Expected_Tests = 0; -sub expected_tests { - my($self, $max) = @_; - - if( defined $max ) { - $Expected_Tests = $max; - $Have_Plan = 1; - - $self->_print("1..$max\n") unless $self->no_header; - } - return $Expected_Tests; -} - - -=item B - - $Test->no_plan; - -Declares that this test will run an indeterminate # of tests. - -=cut - -my($No_Plan) = 0; -sub no_plan { - $No_Plan = 1; - $Have_Plan = 1; -} - -=item B - - $plan = $Test->has_plan - -Find out whether a plan has been defined. $plan is either C (no plan has been set), C (indeterminate # of tests) or an integer (the number of expected tests). - -=cut - -sub has_plan { - return($Expected_Tests) if $Expected_Tests; - return('no_plan') if $No_Plan; - return(undef); -}; - - -=item B - - $Test->skip_all; - $Test->skip_all($reason); - -Skips all the tests, using the given $reason. Exits immediately with 0. - -=cut - -my $Skip_All = 0; -sub skip_all { - my($self, $reason) = @_; - - my $out = "1..0"; - $out .= " # Skip $reason" if $reason; - $out .= "\n"; - - $Skip_All = 1; - - $self->_print($out) unless $self->no_header; - exit(0); -} - -=back - -=head2 Running tests - -These actually run the tests, analogous to the functions in -Test::More. - -$name is always optional. - -=over 4 - -=item B - - $Test->ok($test, $name); - -Your basic test. Pass if $test is true, fail if $test is false. Just -like Test::Simple's ok(). - -=cut - -sub ok { - my($self, $test, $name) = @_; - - # $test might contain an object which we don't want to accidentally - # store, so we turn it into a boolean. - $test = $test ? 1 : 0; - - unless( $Have_Plan ) { - require Carp; - Carp::croak("You tried to run a test without a plan! Gotta have a plan."); - } - - lock $Curr_Test; - $Curr_Test++; - - $self->diag(<caller; - - my $todo = $self->todo($pack); - - my $out; - my $result = {}; - share($result); - - unless( $test ) { - $out .= "not "; - @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); - } - else { - @$result{ 'ok', 'actual_ok' } = ( 1, $test ); - } - - $out .= "ok"; - $out .= " $Curr_Test" if $self->use_numbers; - - if( defined $name ) { - $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. - $out .= " - $name"; - $result->{name} = $name; - } - else { - $result->{name} = ''; - } - - if( $todo ) { - my $what_todo = $todo; - $out .= " # TODO $what_todo"; - $result->{reason} = $what_todo; - $result->{type} = 'todo'; - } - else { - $result->{reason} = ''; - $result->{type} = ''; - } - - $Test_Results[$Curr_Test-1] = $result; - $out .= "\n"; - - $self->_print($out); - - unless( $test ) { - my $msg = $todo ? "Failed (TODO)" : "Failed"; - $self->diag(" $msg test ($file at line $line)\n"); - } - - return $test ? 1 : 0; -} - -=item B - - $Test->is_eq($got, $expected, $name); - -Like Test::More's is(). Checks if $got eq $expected. This is the -string version. - -=item B - - $Test->is_num($got, $expected, $name); - -Like Test::More's is(). Checks if $got == $expected. This is the -numeric version. - -=cut - -sub is_eq { - my($self, $got, $expect, $name) = @_; - local $Level = $Level + 1; - - if( !defined $got || !defined $expect ) { - # undef only matches undef and nothing else - my $test = !defined $got && !defined $expect; - - $self->ok($test, $name); - $self->_is_diag($got, 'eq', $expect) unless $test; - return $test; - } - - return $self->cmp_ok($got, 'eq', $expect, $name); -} - -sub is_num { - my($self, $got, $expect, $name) = @_; - local $Level = $Level + 1; - - if( !defined $got || !defined $expect ) { - # undef only matches undef and nothing else - my $test = !defined $got && !defined $expect; - - $self->ok($test, $name); - $self->_is_diag($got, '==', $expect) unless $test; - return $test; - } - - return $self->cmp_ok($got, '==', $expect, $name); -} - -sub _is_diag { - my($self, $got, $type, $expect) = @_; - - foreach my $val (\$got, \$expect) { - if( defined $$val ) { - if( $type eq 'eq' ) { - # quote and force string context - $$val = "'$$val'" - } - else { - # force numeric context - $$val = $$val+0; - } - } - else { - $$val = 'undef'; - } - } - - return $self->diag(sprintf < - - $Test->isnt_eq($got, $dont_expect, $name); - -Like Test::More's isnt(). Checks if $got ne $dont_expect. This is -the string version. - -=item B - - $Test->is_num($got, $dont_expect, $name); - -Like Test::More's isnt(). Checks if $got ne $dont_expect. This is -the numeric version. - -=cut - -sub isnt_eq { - my($self, $got, $dont_expect, $name) = @_; - local $Level = $Level + 1; - - if( !defined $got || !defined $dont_expect ) { - # undef only matches undef and nothing else - my $test = defined $got || defined $dont_expect; - - $self->ok($test, $name); - $self->_cmp_diag('ne', $got, $dont_expect) unless $test; - return $test; - } - - return $self->cmp_ok($got, 'ne', $dont_expect, $name); -} - -sub isnt_num { - my($self, $got, $dont_expect, $name) = @_; - local $Level = $Level + 1; - - if( !defined $got || !defined $dont_expect ) { - # undef only matches undef and nothing else - my $test = defined $got || defined $dont_expect; - - $self->ok($test, $name); - $self->_cmp_diag('!=', $got, $dont_expect) unless $test; - return $test; - } - - return $self->cmp_ok($got, '!=', $dont_expect, $name); -} - - -=item B - - $Test->like($this, qr/$regex/, $name); - $Test->like($this, '/$regex/', $name); - -Like Test::More's like(). Checks if $this matches the given $regex. - -You'll want to avoid qr// if you want your tests to work before 5.005. - -=item B - - $Test->unlike($this, qr/$regex/, $name); - $Test->unlike($this, '/$regex/', $name); - -Like Test::More's unlike(). Checks if $this B the -given $regex. - -=cut - -sub like { - my($self, $this, $regex, $name) = @_; - - local $Level = $Level + 1; - $self->_regex_ok($this, $regex, '=~', $name); -} - -sub unlike { - my($self, $this, $regex, $name) = @_; - - local $Level = $Level + 1; - $self->_regex_ok($this, $regex, '!~', $name); -} - -=item B - - $Test->maybe_regex(qr/$regex/); - $Test->maybe_regex('/$regex/'); - -Convenience method for building testing functions that take regular -expressions as arguments, but need to work before perl 5.005. - -Takes a quoted regular expression produced by qr//, or a string -representing a regular expression. - -Returns a Perl value which may be used instead of the corresponding -regular expression, or undef if it's argument is not recognised. - -For example, a version of like(), sans the useful diagnostic messages, -could be written as: - - sub laconic_like { - my ($self, $this, $regex, $name) = @_; - my $usable_regex = $self->maybe_regex($regex); - die "expecting regex, found '$regex'\n" - unless $usable_regex; - $self->ok($this =~ m/$usable_regex/, $name); - } - -=cut - - -sub maybe_regex { - my ($self, $regex) = @_; - my $usable_regex = undef; - if( ref $regex eq 'Regexp' ) { - $usable_regex = $regex; - } - # Check if it looks like '/foo/' - elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { - $usable_regex = length $opts ? "(?$opts)$re" : $re; - }; - return($usable_regex) -}; - -sub _regex_ok { - my($self, $this, $regex, $cmp, $name) = @_; - - local $Level = $Level + 1; - - my $ok = 0; - my $usable_regex = $self->maybe_regex($regex); - unless (defined $usable_regex) { - $ok = $self->ok( 0, $name ); - $self->diag(" '$regex' doesn't look much like a regex to me."); - return $ok; - } - - { - local $^W = 0; - my $test = $this =~ /$usable_regex/ ? 1 : 0; - $test = !$test if $cmp eq '!~'; - $ok = $self->ok( $test, $name ); - } - - unless( $ok ) { - $this = defined $this ? "'$this'" : 'undef'; - my $match = $cmp eq '=~' ? "doesn't match" : "matches"; - $self->diag(sprintf < - - $Test->cmp_ok($this, $type, $that, $name); - -Works just like Test::More's cmp_ok(). - - $Test->cmp_ok($big_num, '!=', $other_big_num); - -=cut - -sub cmp_ok { - my($self, $got, $type, $expect, $name) = @_; - - my $test; - { - local $^W = 0; - local($@,$!); # don't interfere with $@ - # eval() sometimes resets $! - $test = eval "\$got $type \$expect"; - } - local $Level = $Level + 1; - my $ok = $self->ok($test, $name); - - unless( $ok ) { - if( $type =~ /^(eq|==)$/ ) { - $self->_is_diag($got, $type, $expect); - } - else { - $self->_cmp_diag($got, $type, $expect); - } - } - return $ok; -} - -sub _cmp_diag { - my($self, $got, $type, $expect) = @_; - - $got = defined $got ? "'$got'" : 'undef'; - $expect = defined $expect ? "'$expect'" : 'undef'; - return $self->diag(sprintf < - - $Test->BAILOUT($reason); - -Indicates to the Test::Harness that things are going so badly all -testing should terminate. This includes running any additional test -scripts. - -It will exit with 255. - -=cut - -sub BAILOUT { - my($self, $reason) = @_; - - $self->_print("Bail out! $reason"); - exit 255; -} - -=item B - - $Test->skip; - $Test->skip($why); - -Skips the current test, reporting $why. - -=cut - -sub skip { - my($self, $why) = @_; - $why ||= ''; - - unless( $Have_Plan ) { - require Carp; - Carp::croak("You tried to run tests without a plan! Gotta have a plan."); - } - - lock($Curr_Test); - $Curr_Test++; - - my %result; - share(%result); - %result = ( - 'ok' => 1, - actual_ok => 1, - name => '', - type => 'skip', - reason => $why, - ); - $Test_Results[$Curr_Test-1] = \%result; - - my $out = "ok"; - $out .= " $Curr_Test" if $self->use_numbers; - $out .= " # skip $why\n"; - - $Test->_print($out); - - return 1; -} - - -=item B - - $Test->todo_skip; - $Test->todo_skip($why); - -Like skip(), only it will declare the test as failing and TODO. Similar -to - - print "not ok $tnum # TODO $why\n"; - -=cut - -sub todo_skip { - my($self, $why) = @_; - $why ||= ''; - - unless( $Have_Plan ) { - require Carp; - Carp::croak("You tried to run tests without a plan! Gotta have a plan."); - } - - lock($Curr_Test); - $Curr_Test++; - - my %result; - share(%result); - %result = ( - 'ok' => 1, - actual_ok => 0, - name => '', - type => 'todo_skip', - reason => $why, - ); - - $Test_Results[$Curr_Test-1] = \%result; - - my $out = "not ok"; - $out .= " $Curr_Test" if $self->use_numbers; - $out .= " # TODO & SKIP $why\n"; - - $Test->_print($out); - - return 1; -} - - -=begin _unimplemented - -=item B - - $Test->skip_rest; - $Test->skip_rest($reason); - -Like skip(), only it skips all the rest of the tests you plan to run -and terminates the test. - -If you're running under no_plan, it skips once and terminates the -test. - -=end _unimplemented - -=back - - -=head2 Test style - -=over 4 - -=item B - - $Test->level($how_high); - -How far up the call stack should $Test look when reporting where the -test failed. - -Defaults to 1. - -Setting $Test::Builder::Level overrides. This is typically useful -localized: - - { - local $Test::Builder::Level = 2; - $Test->ok($test); - } - -=cut - -sub level { - my($self, $level) = @_; - - if( defined $level ) { - $Level = $level; - } - return $Level; -} - -$CLASS->level(1); - - -=item B - - $Test->use_numbers($on_or_off); - -Whether or not the test should output numbers. That is, this if true: - - ok 1 - ok 2 - ok 3 - -or this if false - - ok - ok - ok - -Most useful when you can't depend on the test output order, such as -when threads or forking is involved. - -Test::Harness will accept either, but avoid mixing the two styles. - -Defaults to on. - -=cut - -my $Use_Nums = 1; -sub use_numbers { - my($self, $use_nums) = @_; - - if( defined $use_nums ) { - $Use_Nums = $use_nums; - } - return $Use_Nums; -} - -=item B - - $Test->no_header($no_header); - -If set to true, no "1..N" header will be printed. - -=item B - - $Test->no_ending($no_ending); - -Normally, Test::Builder does some extra diagnostics when the test -ends. It also changes the exit code as described in Test::Simple. - -If this is true, none of that will be done. - -=cut - -my($No_Header, $No_Ending) = (0,0); -sub no_header { - my($self, $no_header) = @_; - - if( defined $no_header ) { - $No_Header = $no_header; - } - return $No_Header; -} - -sub no_ending { - my($self, $no_ending) = @_; - - if( defined $no_ending ) { - $No_Ending = $no_ending; - } - return $No_Ending; -} - - -=back - -=head2 Output - -Controlling where the test output goes. - -It's ok for your test to change where STDOUT and STDERR point to, -Test::Builder's default output settings will not be affected. - -=over 4 - -=item B - - $Test->diag(@msgs); - -Prints out the given $message. Normally, it uses the failure_output() -handle, but if this is for a TODO test, the todo_output() handle is -used. - -Output will be indented and marked with a # so as not to interfere -with test output. A newline will be put on the end if there isn't one -already. - -We encourage using this rather than calling print directly. - -Returns false. Why? Because diag() is often used in conjunction with -a failing test (C) it "passes through" the failure. - - return ok(...) || diag(...); - -=for blame transfer -Mark Fowler - -=cut - -sub diag { - my($self, @msgs) = @_; - return unless @msgs; - - # Prevent printing headers when compiling (i.e. -c) - return if $^C; - - # Escape each line with a #. - foreach (@msgs) { - $_ = 'undef' unless defined; - s/^/# /gms; - } - - push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; - - local $Level = $Level + 1; - my $fh = $self->todo ? $self->todo_output : $self->failure_output; - local($\, $", $,) = (undef, ' ', ''); - print $fh @msgs; - - return 0; -} - -=begin _private - -=item B<_print> - - $Test->_print(@msgs); - -Prints to the output() filehandle. - -=end _private - -=cut - -sub _print { - my($self, @msgs) = @_; - - # Prevent printing headers when only compiling. Mostly for when - # tests are deparsed with B::Deparse - return if $^C; - - local($\, $", $,) = (undef, ' ', ''); - my $fh = $self->output; - - # Escape each line after the first with a # so we don't - # confuse Test::Harness. - foreach (@msgs) { - s/\n(.)/\n# $1/sg; - } - - push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; - - print $fh @msgs; -} - - -=item B - - $Test->output($fh); - $Test->output($file); - -Where normal "ok/not ok" test output should go. - -Defaults to STDOUT. - -=item B - - $Test->failure_output($fh); - $Test->failure_output($file); - -Where diagnostic output on test failures and diag() should go. - -Defaults to STDERR. - -=item B - - $Test->todo_output($fh); - $Test->todo_output($file); - -Where diagnostics about todo test failures and diag() should go. - -Defaults to STDOUT. - -=cut - -my($Out_FH, $Fail_FH, $Todo_FH); -sub output { - my($self, $fh) = @_; - - if( defined $fh ) { - $Out_FH = _new_fh($fh); - } - return $Out_FH; -} - -sub failure_output { - my($self, $fh) = @_; - - if( defined $fh ) { - $Fail_FH = _new_fh($fh); - } - return $Fail_FH; -} - -sub todo_output { - my($self, $fh) = @_; - - if( defined $fh ) { - $Todo_FH = _new_fh($fh); - } - return $Todo_FH; -} - -sub _new_fh { - my($file_or_fh) = shift; - - my $fh; - unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) { - $fh = do { local *FH }; - open $fh, ">$file_or_fh" or - die "Can't open test output log $file_or_fh: $!"; - } - else { - $fh = $file_or_fh; - } - - return $fh; -} - -unless( $^C ) { - # We dup STDOUT and STDERR so people can change them in their - # test suites while still getting normal test output. - open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; - open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; - - # Set everything to unbuffered else plain prints to STDOUT will - # come out in the wrong order from our own prints. - _autoflush(\*TESTOUT); - _autoflush(\*STDOUT); - _autoflush(\*TESTERR); - _autoflush(\*STDERR); - - $CLASS->output(\*TESTOUT); - $CLASS->failure_output(\*TESTERR); - $CLASS->todo_output(\*TESTOUT); -} - -sub _autoflush { - my($fh) = shift; - my $old_fh = select $fh; - $| = 1; - select $old_fh; -} - - -=back - - -=head2 Test Status and Info - -=over 4 - -=item B - - my $curr_test = $Test->current_test; - $Test->current_test($num); - -Gets/sets the current test # we're on. - -You usually shouldn't have to set this. - -=cut - -sub current_test { - my($self, $num) = @_; - - lock($Curr_Test); - if( defined $num ) { - unless( $Have_Plan ) { - require Carp; - Carp::croak("Can't change the current test number without a plan!"); - } - - $Curr_Test = $num; - if( $num > @Test_Results ) { - my $start = @Test_Results ? $#Test_Results + 1 : 0; - for ($start..$num-1) { - my %result; - share(%result); - %result = ( ok => 1, - actual_ok => undef, - reason => 'incrementing test number', - type => 'unknown', - name => undef - ); - $Test_Results[$_] = \%result; - } - } - } - return $Curr_Test; -} - - -=item B

 - - my @tests = $Test->summary; - -A simple summary of the tests so far. True for pass, false for fail. -This is a logical pass/fail, so todos are passes. - -Of course, test #1 is $tests[0], etc... - -=cut - -sub summary { - my($self) = shift; - - return map { $_->{'ok'} } @Test_Results; -} - -=item B
- - my @tests = $Test->details; - -Like summary(), but with a lot more detail. - - $tests[$test_num - 1] = - { 'ok' => is the test considered a pass? - actual_ok => did it literally say 'ok'? - name => name of the test (if any) - type => type of test (if any, see below). - reason => reason for the above (if any) - }; - -'ok' is true if Test::Harness will consider the test to be a pass. - -'actual_ok' is a reflection of whether or not the test literally -printed 'ok' or 'not ok'. This is for examining the result of 'todo' -tests. - -'name' is the name of the test. - -'type' indicates if it was a special test. Normal tests have a type -of ''. Type can be one of the following: - - skip see skip() - todo see todo() - todo_skip see todo_skip() - unknown see below - -Sometimes the Test::Builder test counter is incremented without it -printing any test output, for example, when current_test() is changed. -In these cases, Test::Builder doesn't know the result of the test, so -it's type is 'unkown'. These details for these tests are filled in. -They are considered ok, but the name and actual_ok is left undef. - -For example "not ok 23 - hole count # TODO insufficient donuts" would -result in this structure: - - $tests[22] = # 23 - 1, since arrays start from 0. - { ok => 1, # logically, the test passed since it's todo - actual_ok => 0, # in absolute terms, it failed - name => 'hole count', - type => 'todo', - reason => 'insufficient donuts' - }; - -=cut - -sub details { - return @Test_Results; -} - -=item B - - my $todo_reason = $Test->todo; - my $todo_reason = $Test->todo($pack); - -todo() looks for a $TODO variable in your tests. If set, all tests -will be considered 'todo' (see Test::More and Test::Harness for -details). Returns the reason (ie. the value of $TODO) if running as -todo tests, false otherwise. - -todo() is pretty part about finding the right package to look for -$TODO in. It uses the exported_to() package to find it. If that's -not set, it's pretty good at guessing the right package to look at. - -Sometimes there is some confusion about where todo() should be looking -for the $TODO variable. If you want to be sure, tell it explicitly -what $pack to use. - -=cut - -sub todo { - my($self, $pack) = @_; - - $pack = $pack || $self->exported_to || $self->caller(1); - - no strict 'refs'; - return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} - : 0; -} - -=item B - - my $package = $Test->caller; - my($pack, $file, $line) = $Test->caller; - my($pack, $file, $line) = $Test->caller($height); - -Like the normal caller(), except it reports according to your level(). - -=cut - -sub caller { - my($self, $height) = @_; - $height ||= 0; - - my @caller = CORE::caller($self->level + $height + 1); - return wantarray ? @caller : $caller[0]; -} - -=back - -=cut - -=begin _private - -=over 4 - -=item B<_sanity_check> - - _sanity_check(); - -Runs a bunch of end of test sanity checks to make sure reality came -through ok. If anything is wrong it will die with a fairly friendly -error message. - -=cut - -#'# -sub _sanity_check { - _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); - _whoa(!$Have_Plan and $Curr_Test, - 'Somehow your tests ran without a plan!'); - _whoa($Curr_Test != @Test_Results, - 'Somehow you got a different number of results than tests ran!'); -} - -=item B<_whoa> - - _whoa($check, $description); - -A sanity check, similar to assert(). If the $check is true, something -has gone horribly wrong. It will die with the given $description and -a note to contact the author. - -=cut - -sub _whoa { - my($check, $desc) = @_; - if( $check ) { - die < - - _my_exit($exit_num); - -Perl seems to have some trouble with exiting inside an END block. 5.005_03 -and 5.6.1 both seem to do odd things. Instead, this function edits $? -directly. It should ONLY be called from inside an END block. It -doesn't actually exit, that's your job. - -=cut - -sub _my_exit { - $? = $_[0]; - - return 1; -} - - -=back - -=end _private - -=cut - -$SIG{__DIE__} = sub { - # We don't want to muck with death in an eval, but $^S isn't - # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing - # with it. Instead, we use caller. This also means it runs under - # 5.004! - my $in_eval = 0; - for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { - $in_eval = 1 if $sub =~ /^\(eval\)/; - } - $Test_Died = 1 unless $in_eval; -}; - -sub _ending { - my $self = shift; - - _sanity_check(); - - # Don't bother with an ending if this is a forked copy. Only the parent - # should do the ending. - do{ _my_exit($?) && return } if $Original_Pid != $$; - - # Bailout if plan() was never called. This is so - # "require Test::Simple" doesn't puke. - do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died; - - # Figure out if we passed or failed and print helpful messages. - if( @Test_Results ) { - # The plan? We have no plan. - if( $No_Plan ) { - $self->_print("1..$Curr_Test\n") unless $self->no_header; - $Expected_Tests = $Curr_Test; - } - - # 5.8.0 threads bug. Shared arrays will not be auto-extended - # by a slice. Worse, we have to fill in every entry else - # we'll get an "Invalid value for shared scalar" error - for my $idx ($#Test_Results..$Expected_Tests-1) { - my %empty_result = (); - share(%empty_result); - $Test_Results[$idx] = \%empty_result - unless defined $Test_Results[$idx]; - } - - my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1]; - $num_failed += abs($Expected_Tests - @Test_Results); - - if( $Curr_Test < $Expected_Tests ) { - $self->diag(<<"FAIL"); -Looks like you planned $Expected_Tests tests but only ran $Curr_Test. -FAIL - } - elsif( $Curr_Test > $Expected_Tests ) { - my $num_extra = $Curr_Test - $Expected_Tests; - $self->diag(<<"FAIL"); -Looks like you planned $Expected_Tests tests but ran $num_extra extra. -FAIL - } - elsif ( $num_failed ) { - $self->diag(<<"FAIL"); -Looks like you failed $num_failed tests of $Expected_Tests. -FAIL - } - - if( $Test_Died ) { - $self->diag(<<"FAIL"); -Looks like your test died just after $Curr_Test. -FAIL - - _my_exit( 255 ) && return; - } - - _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; - } - elsif ( $Skip_All ) { - _my_exit( 0 ) && return; - } - elsif ( $Test_Died ) { - $self->diag(<<'FAIL'); -Looks like your test died before it could output anything. -FAIL - } - else { - $self->diag("No tests run!\n"); - _my_exit( 255 ) && return; - } -} - -END { - $Test->_ending if defined $Test and !$Test->no_ending; -} - -=head1 THREADS - -In perl 5.8.0 and later, Test::Builder is thread-safe. The test -number is shared amongst all threads. This means if one thread sets -the test number using current_test() they will all be effected. - -=head1 EXAMPLES - -CPAN can provide the best examples. Test::Simple, Test::More, -Test::Exception and Test::Differences all use Test::Builder. - -=head1 SEE ALSO - -Test::Simple, Test::More, Test::Harness - -=head1 AUTHORS - -Original code by chromatic, maintained by Michael G Schwern -Eschwern@pobox.comE - -=head1 COPYRIGHT - -Copyright 2002 by chromatic Echromatic@wgz.orgE, - Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut - -1; diff --git a/Perl/t/Test/Harness.pm b/Perl/t/Test/Harness.pm deleted file mode 100644 index 0897455..0000000 --- a/Perl/t/Test/Harness.pm +++ /dev/null @@ -1,1168 +0,0 @@ -# -*- Mode: cperl; cperl-indent-level: 4 -*- -# $Id$ - -package Test::Harness; - -require 5.004; -use Test::Harness::Straps; -use Test::Harness::Assert; -use Exporter; -use Benchmark; -use Config; -use strict; - -use vars qw($VERSION $Verbose $Switches $Have_Devel_Corestack $Curtest - $Columns $verbose $switches $ML $Strap - @ISA @EXPORT @EXPORT_OK $Last_ML_Print - ); - -# Backwards compatibility for exportable variable names. -*verbose = *Verbose; -*switches = *Switches; - -$Have_Devel_Corestack = 0; - -$VERSION = '2.30'; - -$ENV{HARNESS_ACTIVE} = 1; - -END { - # For VMS. - delete $ENV{HARNESS_ACTIVE}; -} - -# Some experimental versions of OS/2 build have broken $? -my $Ignore_Exitcode = $ENV{HARNESS_IGNORE_EXITCODE}; - -my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR}; - -my $Ok_Slow = $ENV{HARNESS_OK_SLOW}; - -$Strap = Test::Harness::Straps->new; - -@ISA = ('Exporter'); -@EXPORT = qw(&runtests); -@EXPORT_OK = qw($verbose $switches); - -$Verbose = $ENV{HARNESS_VERBOSE} || 0; -$Switches = "-w"; -$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; -$Columns--; # Some shells have trouble with a full line of text. - - -=head1 NAME - -Test::Harness - run perl standard test scripts with statistics - -=head1 SYNOPSIS - - use Test::Harness; - - runtests(@test_files); - -=head1 DESCRIPTION - -B If all you want to do is write a test script, consider using -Test::Simple. Otherwise, read on. - -(By using the Test module, you can write test scripts without -knowing the exact output this module expects. However, if you need to -know the specifics, read on!) - -Perl test scripts print to standard output C<"ok N"> for each single -test, where C is an increasing sequence of integers. The first line -output by a standard test script is C<"1..M"> with C being the -number of tests that should be run within the test -script. Test::Harness::runtests(@tests) runs all the testscripts -named as arguments and checks standard output for the expected -C<"ok N"> strings. - -After all tests have been performed, runtests() prints some -performance statistics that are computed by the Benchmark module. - -=head2 The test script output - -The following explains how Test::Harness interprets the output of your -test program. - -=over 4 - -=item B<'1..M'> - -This header tells how many tests there will be. For example, C<1..10> -means you plan on running 10 tests. This is a safeguard in case your -test dies quietly in the middle of its run. - -It should be the first non-comment line output by your test program. - -In certain instances, you may not know how many tests you will -ultimately be running. In this case, it is permitted for the 1..M -header to appear as the B line output by your test (again, it -can be followed by further comments). - -Under B circumstances should 1..M appear in the middle of your -output or more than once. - - -=item B<'ok', 'not ok'. Ok?> - -Any output from the testscript to standard error is ignored and -bypassed, thus will be seen by the user. Lines written to standard -output containing C are interpreted as feedback for -runtests(). All other lines are discarded. - -C indicates a failed test. C is a successful test. - - -=item B - -Perl normally expects the 'ok' or 'not ok' to be followed by a test -number. It is tolerated if the test numbers after 'ok' are -omitted. In this case Test::Harness maintains temporarily its own -counter until the script supplies test numbers again. So the following -test script - - print < - -Anything after the test number but before the # is considered to be -the name of the test. - - ok 42 this is the name of the test - -Currently, Test::Harness does nothing with this information. - -=item B - -If the standard output line contains the substring C< # Skip> (with -variations in spacing and case) after C or C, it is -counted as a skipped test. If the whole testscript succeeds, the -count of skipped tests is included in the generated output. -C reports the text after C< # Skip\S*\s+> as a reason -for skipping. - - ok 23 # skip Insufficient flogiston pressure. - -Similarly, one can include a similar explanation in a C<1..0> line -emitted if the test script is skipped completely: - - 1..0 # Skipped: no leverage found - -=item B - -If the standard output line contains the substring C< # TODO> after -C or C, it is counted as a todo test. The text -afterwards is the thing that has to be done before this test will -succeed. - - not ok 13 # TODO harness the power of the atom - -=begin _deprecated - -Alternatively, you can specify a list of what tests are todo as part -of the test header. - - 1..23 todo 5 12 23 - -This only works if the header appears at the beginning of the test. - -This style is B. - -=end _deprecated - -These tests represent a feature to be implemented or a bug to be fixed -and act as something of an executable "thing to do" list. They are -B expected to succeed. Should a todo test begin succeeding, -Test::Harness will report it as a bonus. This indicates that whatever -you were supposed to do has been done and you should promote this to a -normal test. - -=item B - -As an emergency measure, a test script can decide that further tests -are useless (e.g. missing dependencies) and testing should stop -immediately. In that case the test script prints the magic words - - Bail out! - -to standard output. Any message after these words will be displayed by -C as the reason why testing is stopped. - -=item B - -Additional comments may be put into the testing output on their own -lines. Comment lines should begin with a '#', Test::Harness will -ignore them. - - ok 1 - # Life is good, the sun is shining, RAM is cheap. - not ok 2 - # got 'Bush' expected 'Gore' - -=item B - -Any other output Test::Harness sees it will silently ignore B If you wish to place additional output in your -test script, please use a comment. - -=back - - -=head2 Taint mode - -Test::Harness will honor the C<-T> in the #! line on your test files. So -if you begin a test with: - - #!perl -T - -the test will be run with taint mode on. - - -=head2 Configuration variables. - -These variables can be used to configure the behavior of -Test::Harness. They are exported on request. - -=over 4 - -=item B<$Test::Harness::verbose> - -The global variable $Test::Harness::verbose is exportable and can be -used to let runtests() display the standard output of the script -without altering the behavior otherwise. - -=item B<$Test::Harness::switches> - -The global variable $Test::Harness::switches is exportable and can be -used to set perl command line options used for running the test -script(s). The default value is C<-w>. - -=back - - -=head2 Failure - -It will happen, your tests will fail. After you mop up your ego, you -can begin examining the summary report: - - t/base..............ok - t/nonumbers.........ok - t/ok................ok - t/test-harness......ok - t/waterloo..........dubious - Test returned status 3 (wstat 768, 0x300) - DIED. FAILED tests 1, 3, 5, 7, 9, 11, 13, 15, 17, 19 - Failed 10/20 tests, 50.00% okay - Failed Test Stat Wstat Total Fail Failed List of Failed - ----------------------------------------------------------------------- - t/waterloo.t 3 768 20 10 50.00% 1 3 5 7 9 11 13 15 17 19 - Failed 1/5 test scripts, 80.00% okay. 10/44 subtests failed, 77.27% okay. - -Everything passed but t/waterloo.t. It failed 10 of 20 tests and -exited with non-zero status indicating something dubious happened. - -The columns in the summary report mean: - -=over 4 - -=item B - -The test file which failed. - -=item B - -If the test exited with non-zero, this is its exit status. - -=item B - -The wait status of the test I. - -=item B - -Total number of tests expected to run. - -=item B - -Number which failed, either from "not ok" or because they never ran. - -=item B - -Percentage of the total tests which failed. - -=item B - -A list of the tests which failed. Successive failures may be -abbreviated (ie. 15-20 to indicate that tests 15, 16, 17, 18, 19 and -20 failed). - -=back - - -=head2 Functions - -Test::Harness currently only has one function, here it is. - -=over 4 - -=item B - - my $allok = runtests(@test_files); - -This runs all the given @test_files and divines whether they passed -or failed based on their output to STDOUT (details above). It prints -out each individual test which failed along with a summary report and -a how long it all took. - -It returns true if everything was ok. Otherwise it will die() with -one of the messages in the DIAGNOSTICS section. - -=for _private - -This is just _run_all_tests() plus _show_results() - -=cut - -sub runtests { - my(@tests) = @_; - - local ($\, $,); - - my($tot, $failedtests) = _run_all_tests(@tests); - _show_results($tot, $failedtests); - - my $ok = _all_ok($tot); - - assert(($ok xor keys %$failedtests), - q{ok status jives with $failedtests}); - - return $ok; -} - -=begin _private - -=item B<_all_ok> - - my $ok = _all_ok(\%tot); - -Tells you if this test run is overall successful or not. - -=cut - -sub _all_ok { - my($tot) = shift; - - return $tot->{bad} == 0 && ($tot->{max} || $tot->{skipped}) ? 1 : 0; -} - -=item B<_globdir> - - my @files = _globdir $dir; - -Returns all the files in a directory. This is shorthand for backwards -compatibility on systems where glob() doesn't work right. - -=cut - -sub _globdir { - opendir DIRH, shift; - my @f = readdir DIRH; - closedir DIRH; - - return @f; -} - -=item B<_run_all_tests> - - my($total, $failed) = _run_all_tests(@test_files); - -Runs all the given @test_files (as runtests()) but does it quietly (no -report). $total is a hash ref summary of all the tests run. Its keys -and values are this: - - bonus Number of individual todo tests unexpectedly passed - max Number of individual tests ran - ok Number of individual tests passed - sub_skipped Number of individual tests skipped - todo Number of individual todo tests - - files Number of test files ran - good Number of test files passed - bad Number of test files failed - tests Number of test files originally given - skipped Number of test files skipped - -If $total->{bad} == 0 and $total->{max} > 0, you've got a successful -test. - -$failed is a hash ref of all the test scripts which failed. Each key -is the name of a test script, each value is another hash representing -how that script failed. Its keys are these: - - name Name of the test which failed - estat Script's exit value - wstat Script's wait status - max Number of individual tests - failed Number which failed - percent Percentage of tests which failed - canon List of tests which failed (as string). - -Needless to say, $failed should be empty if everything passed. - -B Currently this function is still noisy. I'm working on it. - -=cut - -#'# -sub _run_all_tests { - my(@tests) = @_; - local($|) = 1; - my(%failedtests); - - # Test-wide totals. - my(%tot) = ( - bonus => 0, - max => 0, - ok => 0, - files => 0, - bad => 0, - good => 0, - tests => scalar @tests, - sub_skipped => 0, - todo => 0, - skipped => 0, - bench => 0, - ); - - my @dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir; - my $t_start = new Benchmark; - - my $width = _leader_width(@tests); - foreach my $tfile (@tests) { - $Last_ML_Print = 0; # so each test prints at least once - my($leader, $ml) = _mk_leader($tfile, $width); - local $ML = $ml; - print $leader; - - $tot{files}++; - - $Strap->{_seen_header} = 0; - my %results = $Strap->analyze_file($tfile) or - do { warn "$Strap->{error}\n"; next }; - - # state of the current test. - my @failed = grep { !$results{details}[$_-1]{ok} } - 1..@{$results{details}}; - my %test = ( - ok => $results{ok}, - 'next' => $Strap->{'next'}, - max => $results{max}, - failed => \@failed, - bonus => $results{bonus}, - skipped => $results{skip}, - skip_reason => $results{skip_reason}, - skip_all => $Strap->{skip_all}, - ml => $ml, - ); - - $tot{bonus} += $results{bonus}; - $tot{max} += $results{max}; - $tot{ok} += $results{ok}; - $tot{todo} += $results{todo}; - $tot{sub_skipped} += $results{skip}; - - my($estatus, $wstatus) = @results{qw(exit wait)}; - - if ($results{passing}) { - if ($test{max} and $test{skipped} + $test{bonus}) { - my @msg; - push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}") - if $test{skipped}; - push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded") - if $test{bonus}; - print "$test{ml}ok\n ".join(', ', @msg)."\n"; - } elsif ($test{max}) { - print "$test{ml}ok\n"; - } elsif (defined $test{skip_all} and length $test{skip_all}) { - print "skipped\n all skipped: $test{skip_all}\n"; - $tot{skipped}++; - } else { - print "skipped\n all skipped: no reason given\n"; - $tot{skipped}++; - } - $tot{good}++; - } - else { - # List unrun tests as failures. - if ($test{'next'} <= $test{max}) { - push @{$test{failed}}, $test{'next'}..$test{max}; - } - # List overruns as failures. - else { - my $details = $results{details}; - foreach my $overrun ($test{max}+1..@$details) - { - next unless ref $details->[$overrun-1]; - push @{$test{failed}}, $overrun - } - } - - if ($wstatus) { - $failedtests{$tfile} = _dubious_return(\%test, \%tot, - $estatus, $wstatus); - $failedtests{$tfile}{name} = $tfile; - } - elsif($results{seen}) { - if (@{$test{failed}} and $test{max}) { - my ($txt, $canon) = canonfailed($test{max},$test{skipped}, - @{$test{failed}}); - print "$test{ml}$txt"; - $failedtests{$tfile} = { canon => $canon, - max => $test{max}, - failed => scalar @{$test{failed}}, - name => $tfile, - percent => 100*(scalar @{$test{failed}})/$test{max}, - estat => '', - wstat => '', - }; - } else { - print "Don't know which tests failed: got $test{ok} ok, ". - "expected $test{max}\n"; - $failedtests{$tfile} = { canon => '??', - max => $test{max}, - failed => '??', - name => $tfile, - percent => undef, - estat => '', - wstat => '', - }; - } - $tot{bad}++; - } else { - print "FAILED before any test output arrived\n"; - $tot{bad}++; - $failedtests{$tfile} = { canon => '??', - max => '??', - failed => '??', - name => $tfile, - percent => undef, - estat => '', - wstat => '', - }; - } - } - - if (defined $Files_In_Dir) { - my @new_dir_files = _globdir $Files_In_Dir; - if (@new_dir_files != @dir_files) { - my %f; - @f{@new_dir_files} = (1) x @new_dir_files; - delete @f{@dir_files}; - my @f = sort keys %f; - print "LEAKED FILES: @f\n"; - @dir_files = @new_dir_files; - } - } - } - $tot{bench} = timediff(new Benchmark, $t_start); - - $Strap->_restore_PERL5LIB; - - return(\%tot, \%failedtests); -} - -=item B<_mk_leader> - - my($leader, $ml) = _mk_leader($test_file, $width); - -Generates the 't/foo........' $leader for the given $test_file as well -as a similar version which will overwrite the current line (by use of -\r and such). $ml may be empty if Test::Harness doesn't think you're -on TTY. - -The $width is the width of the "yada/blah.." string. - -=cut - -sub _mk_leader { - my($te, $width) = @_; - chomp($te); - $te =~ s/\.\w+$/./; - - if ($^O eq 'VMS') { $te =~ s/^.*\.t\./\[.t./s; } - my $blank = (' ' x 77); - my $leader = "$te" . '.' x ($width - length($te)); - my $ml = ""; - - $ml = "\r$blank\r$leader" - if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose; - - return($leader, $ml); -} - -=item B<_leader_width> - - my($width) = _leader_width(@test_files); - -Calculates how wide the leader should be based on the length of the -longest test name. - -=cut - -sub _leader_width { - my $maxlen = 0; - my $maxsuflen = 0; - foreach (@_) { - my $suf = /\.(\w+)$/ ? $1 : ''; - my $len = length; - my $suflen = length $suf; - $maxlen = $len if $len > $maxlen; - $maxsuflen = $suflen if $suflen > $maxsuflen; - } - # + 3 : we want three dots between the test name and the "ok" - return $maxlen + 3 - $maxsuflen; -} - - -sub _show_results { - my($tot, $failedtests) = @_; - - my $pct; - my $bonusmsg = _bonusmsg($tot); - - if (_all_ok($tot)) { - print "All tests successful$bonusmsg.\n"; - } elsif (!$tot->{tests}){ - die "FAILED--no tests were run for some reason.\n"; - } elsif (!$tot->{max}) { - my $blurb = $tot->{tests}==1 ? "script" : "scripts"; - die "FAILED--$tot->{tests} test $blurb could be run, ". - "alas--no output ever seen\n"; - } else { - $pct = sprintf("%.2f", $tot->{good} / $tot->{tests} * 100); - my $percent_ok = 100*$tot->{ok}/$tot->{max}; - my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.", - $tot->{max} - $tot->{ok}, $tot->{max}, - $percent_ok; - - my($fmt_top, $fmt) = _create_fmts($failedtests); - - # Now write to formats - for my $script (sort keys %$failedtests) { - $Curtest = $failedtests->{$script}; - write; - } - if ($tot->{bad}) { - $bonusmsg =~ s/^,\s*//; - print "$bonusmsg.\n" if $bonusmsg; - die "Failed $tot->{bad}/$tot->{tests} test scripts, $pct% okay.". - "$subpct\n"; - } - } - - printf("Files=%d, Tests=%d, %s\n", - $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop')); -} - - -my %Handlers = (); -$Strap->{callback} = sub { - my($self, $line, $type, $totals) = @_; - print $line if $Verbose; - - my $meth = $Handlers{$type}; - $meth->($self, $line, $type, $totals) if $meth; -}; - - -$Handlers{header} = sub { - my($self, $line, $type, $totals) = @_; - - warn "Test header seen more than once!\n" if $self->{_seen_header}; - - $self->{_seen_header}++; - - warn "1..M can only appear at the beginning or end of tests\n" - if $totals->{seen} && - $totals->{max} < $totals->{seen}; -}; - -$Handlers{test} = sub { - my($self, $line, $type, $totals) = @_; - - my $curr = $totals->{seen}; - my $next = $self->{'next'}; - my $max = $totals->{max}; - my $detail = $totals->{details}[-1]; - - if( $detail->{ok} ) { - _print_ml_less("ok $curr/$max"); - - if( $detail->{type} eq 'skip' ) { - $totals->{skip_reason} = $detail->{reason} - unless defined $totals->{skip_reason}; - $totals->{skip_reason} = 'various reasons' - if $totals->{skip_reason} ne $detail->{reason}; - } - } - else { - _print_ml("NOK $curr"); - } - - if( $curr > $next ) { - print "Test output counter mismatch [test $curr]\n"; - } - elsif( $curr < $next ) { - print "Confused test output: test $curr answered after ". - "test ", $next - 1, "\n"; - } - -}; - -$Handlers{bailout} = sub { - my($self, $line, $type, $totals) = @_; - - die "FAILED--Further testing stopped" . - ($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n"); -}; - - -sub _print_ml { - print join '', $ML, @_ if $ML; -} - - -# For slow connections, we save lots of bandwidth by printing only once -# per second. -sub _print_ml_less { - if( !$Ok_Slow || $Last_ML_Print != time ) { - _print_ml(@_); - $Last_ML_Print = time; - } -} - -sub _bonusmsg { - my($tot) = @_; - - my $bonusmsg = ''; - $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : ''). - " UNEXPECTEDLY SUCCEEDED)") - if $tot->{bonus}; - - if ($tot->{skipped}) { - $bonusmsg .= ", $tot->{skipped} test" - . ($tot->{skipped} != 1 ? 's' : ''); - if ($tot->{sub_skipped}) { - $bonusmsg .= " and $tot->{sub_skipped} subtest" - . ($tot->{sub_skipped} != 1 ? 's' : ''); - } - $bonusmsg .= ' skipped'; - } - elsif ($tot->{sub_skipped}) { - $bonusmsg .= ", $tot->{sub_skipped} subtest" - . ($tot->{sub_skipped} != 1 ? 's' : '') - . " skipped"; - } - - return $bonusmsg; -} - -# Test program go boom. -sub _dubious_return { - my($test, $tot, $estatus, $wstatus) = @_; - my ($failed, $canon, $percent) = ('??', '??'); - - printf "$test->{ml}dubious\n\tTest returned status $estatus ". - "(wstat %d, 0x%x)\n", - $wstatus,$wstatus; - print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS'; - - if (corestatus($wstatus)) { # until we have a wait module - if ($Have_Devel_Corestack) { - Devel::CoreStack::stack($^X); - } else { - print "\ttest program seems to have generated a core\n"; - } - } - - $tot->{bad}++; - - if ($test->{max}) { - if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) { - print "\tafter all the subtests completed successfully\n"; - $percent = 0; - $failed = 0; # But we do not set $canon! - } - else { - push @{$test->{failed}}, $test->{'next'}..$test->{max}; - $failed = @{$test->{failed}}; - (my $txt, $canon) = canonfailed($test->{max},$test->{skipped},@{$test->{failed}}); - $percent = 100*(scalar @{$test->{failed}})/$test->{max}; - print "DIED. ",$txt; - } - } - - return { canon => $canon, max => $test->{max} || '??', - failed => $failed, - percent => $percent, - estat => $estatus, wstat => $wstatus, - }; -} - - -sub _create_fmts { - my($failedtests) = @_; - - my $failed_str = "Failed Test"; - my $middle_str = " Stat Wstat Total Fail Failed "; - my $list_str = "List of Failed"; - - # Figure out our longest name string for formatting purposes. - my $max_namelen = length($failed_str); - foreach my $script (keys %$failedtests) { - my $namelen = length $failedtests->{$script}->{name}; - $max_namelen = $namelen if $namelen > $max_namelen; - } - - my $list_len = $Columns - length($middle_str) - $max_namelen; - if ($list_len < length($list_str)) { - $list_len = length($list_str); - $max_namelen = $Columns - length($middle_str) - $list_len; - if ($max_namelen < length($failed_str)) { - $max_namelen = length($failed_str); - $Columns = $max_namelen + length($middle_str) + $list_len; - } - } - - my $fmt_top = "format STDOUT_TOP =\n" - . sprintf("%-${max_namelen}s", $failed_str) - . $middle_str - . $list_str . "\n" - . "-" x $Columns - . "\n.\n"; - - my $fmt = "format STDOUT =\n" - . "@" . "<" x ($max_namelen - 1) - . " @>> @>>>> @>>>> @>>> ^##.##% " - . "^" . "<" x ($list_len - 1) . "\n" - . '{ $Curtest->{name}, $Curtest->{estat},' - . ' $Curtest->{wstat}, $Curtest->{max},' - . ' $Curtest->{failed}, $Curtest->{percent},' - . ' $Curtest->{canon}' - . "\n}\n" - . "~~" . " " x ($Columns - $list_len - 2) . "^" - . "<" x ($list_len - 1) . "\n" - . '$Curtest->{canon}' - . "\n.\n"; - - eval $fmt_top; - die $@ if $@; - eval $fmt; - die $@ if $@; - - return($fmt_top, $fmt); -} - -{ - my $tried_devel_corestack; - - sub corestatus { - my($st) = @_; - - my $did_core; - eval { # we may not have a WCOREDUMP - local $^W = 0; # *.ph files are often *very* noisy - require 'wait.ph'; - $did_core = WCOREDUMP($st); - }; - if( $@ ) { - $did_core = $st & 0200; - } - - eval { require Devel::CoreStack; $Have_Devel_Corestack++ } - unless $tried_devel_corestack++; - - return $did_core; - } -} - -sub canonfailed ($$@) { - my($max,$skipped,@failed) = @_; - my %seen; - @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed; - my $failed = @failed; - my @result = (); - my @canon = (); - my $min; - my $last = $min = shift @failed; - my $canon; - if (@failed) { - for (@failed, $failed[-1]) { # don't forget the last one - if ($_ > $last+1 || $_ == $last) { - if ($min == $last) { - push @canon, $last; - } else { - push @canon, "$min-$last"; - } - $min = $_; - } - $last = $_; - } - local $" = ", "; - push @result, "FAILED tests @canon\n"; - $canon = join ' ', @canon; - } else { - push @result, "FAILED test $last\n"; - $canon = $last; - } - - push @result, "\tFailed $failed/$max tests, "; - if ($max) { - push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay"; - } else { - push @result, "?% okay"; - } - my $ender = 's' x ($skipped > 1); - my $good = $max - $failed - $skipped; - if ($skipped) { - my $skipmsg = " (less $skipped skipped test$ender: $good okay, "; - if ($max) { - my $goodper = sprintf("%.2f",100*($good/$max)); - $skipmsg .= "$goodper%)"; - } else { - $skipmsg .= "?%)"; - } - push @result, $skipmsg; - } - push @result, "\n"; - my $txt = join "", @result; - ($txt, $canon); -} - -=end _private - -=back - -=cut - - -1; -__END__ - - -=head1 EXPORT - -C<&runtests> is exported by Test::Harness by default. - -C<$verbose> and C<$switches> are exported upon request. - - -=head1 DIAGNOSTICS - -=over 4 - -=item C - -If all tests are successful some statistics about the performance are -printed. - -=item C - -For any single script that has failing subtests statistics like the -above are printed. - -=item C - -Scripts that return a non-zero exit status, both C<$? EE 8> -and C<$?> are printed in a message similar to the above. - -=item C - -=item C - -If not all tests were successful, the script dies with one of the -above messages. - -=item C - -If a single subtest decides that further testing will not make sense, -the script dies with this message. - -=back - -=head1 ENVIRONMENT - -=over 4 - -=item C - -Harness sets this before executing the individual tests. This allows -the tests to determine if they are being executed through the harness -or by any other means. - -=item C - -This value will be used for the width of the terminal. If it is not -set then it will default to C. If this is not set, it will -default to 80. Note that users of Bourne-sh based shells will need to -C for this module to use that variable. - -=item C - -When true it will make harness attempt to compile the test using -C before running it. - -B This currently only works when sitting in the perl source -directory! - -=item C - -When set to the name of a directory, harness will check after each -test whether new files appeared in that directory, and report them as - - LEAKED FILES: scr.tmp 0 my.db - -If relative, directory name is with respect to the current directory at -the moment runtests() was called. Putting absolute path into -C may give more predictable results. - -=item C - -Makes harness ignore the exit status of child processes when defined. - -=item C - -When set to a true value, forces it to behave as though STDOUT were -not a console. You may need to set this if you don't want harness to -output more frequent progress messages using carriage returns. Some -consoles may not handle carriage returns properly (which results in a -somewhat messy output). - -=item C - -If true, the C messages are printed out only every second. -This reduces output and therefore may for example help testing -over slow connections. - -=item C - -Its value will be prepended to the switches used to invoke perl on -each test. For example, setting C to C<-W> will -run all tests with all warnings enabled. - -=item C - -If true, Test::Harness will output the verbose results of running -its tests. Setting $Test::Harness::verbose will override this. - -=back - -=head1 EXAMPLE - -Here's how Test::Harness tests itself - - $ cd ~/src/devel/Test-Harness - $ perl -Mblib -e 'use Test::Harness qw(&runtests $verbose); - $verbose=0; runtests @ARGV;' t/*.t - Using /home/schwern/src/devel/Test-Harness/blib - t/base..............ok - t/nonumbers.........ok - t/ok................ok - t/test-harness......ok - All tests successful. - Files=4, Tests=24, 2 wallclock secs ( 0.61 cusr + 0.41 csys = 1.02 CPU) - -=head1 SEE ALSO - -L and L for writing test scripts, L for -the underlying timing routines, L to generate core -dumps from failed tests and L for test coverage -analysis. - -=head1 AUTHORS - -Either Tim Bunce or Andreas Koenig, we don't know. What we know for -sure is, that it was inspired by Larry Wall's TEST script that came -with perl distributions for ages. Numerous anonymous contributors -exist. Andreas Koenig held the torch for many years, and then -Michael G Schwern. - -Current maintainer is Andy Lester C<< >>. - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See L - -=head1 TODO - -Provide a way of running tests quietly (ie. no printing) for automated -validation of tests. This will probably take the form of a version -of runtests() which rather than printing its output returns raw data -on the state of the tests. (Partially done in Test::Harness::Straps) - -Document the format. - -Fix HARNESS_COMPILE_TEST without breaking its core usage. - -Figure a way to report test names in the failure summary. - -Rework the test summary so long test names are not truncated as badly. -(Partially done with new skip test styles) - -Deal with VMS's "not \nok 4\n" mistake. - -Add option for coverage analysis. - -Trap STDERR. - -Implement Straps total_results() - -Remember exit code - -Completely redo the print summary code. - -Implement Straps callbacks. (experimentally implemented) - -Straps->analyze_file() not taint clean, don't know if it can be - -Fix that damned VMS nit. - -HARNESS_TODOFAIL to display TODO failures - -Add a test for verbose. - -Change internal list of test results to a hash. - -Fix stats display when there's an overrun. - -Fix so perls with spaces in the filename work. - -=for _private - -Keeping whittling away at _run_all_tests() - -=for _private - -Clean up how the summary is printed. Get rid of those damned formats. - -=head1 BUGS - -HARNESS_COMPILE_TEST currently assumes it's run from the Perl source -directory. - -=cut diff --git a/Perl/t/Test/Harness/Assert.pm b/Perl/t/Test/Harness/Assert.pm deleted file mode 100644 index 3ee23e3..0000000 --- a/Perl/t/Test/Harness/Assert.pm +++ /dev/null @@ -1,68 +0,0 @@ -# $Id$ - -package Test::Harness::Assert; - -use strict; -require Exporter; -use vars qw($VERSION @EXPORT @ISA); - -$VERSION = '0.01'; - -@ISA = qw(Exporter); -@EXPORT = qw(assert); - - -=head1 NAME - -Test::Harness::Assert - simple assert - -=head1 SYNOPSIS - - ### FOR INTERNAL USE ONLY ### - - use Test::Harness::Assert; - - assert( EXPR, $name ); - -=head1 DESCRIPTION - -A simple assert routine since we don't have Carp::Assert handy. - -B - -=head2 Functions - -=over 4 - -=item B - - assert( EXPR, $name ); - -If the expression is false the program aborts. - -=cut - -sub assert ($;$) { - my($assert, $name) = @_; - - unless( $assert ) { - require Carp; - my $msg = 'Assert failed'; - $msg .= " - '$name'" if defined $name; - $msg .= '!'; - Carp::croak($msg); - } - -} - -=head1 AUTHOR - -Michael G Schwern Eschwern@pobox.comE - -=head1 SEE ALSO - -L - -=cut - -1; diff --git a/Perl/t/Test/Harness/Iterator.pm b/Perl/t/Test/Harness/Iterator.pm deleted file mode 100644 index 5e22793..0000000 --- a/Perl/t/Test/Harness/Iterator.pm +++ /dev/null @@ -1,61 +0,0 @@ -package Test::Harness::Iterator; - -use strict; -use vars qw($VERSION); -$VERSION = 0.01; - - -=head1 NAME - -Test::Harness::Iterator - Internal Test::Harness Iterator - -=head1 SYNOPSIS - - use Test::Harness::Iterator; - use Test::Harness::Iterator; - my $it = Test::Harness::Iterator->new(\*TEST); - my $it = Test::Harness::Iterator->new(\@array); - - my $line = $it->next; - - -=head1 DESCRIPTION - -B - -This is a simple iterator wrapper for arrays and filehandles. - -=cut - -sub new { - my($proto, $thing) = @_; - - my $self = {}; - if( ref $thing eq 'GLOB' ) { - bless $self, 'Test::Harness::Iterator::FH'; - $self->{fh} = $thing; - } - elsif( ref $thing eq 'ARRAY' ) { - bless $self, 'Test::Harness::Iterator::ARRAY'; - $self->{idx} = 0; - $self->{array} = $thing; - } - else { - warn "Can't iterate with a ", ref $thing; - } - - return $self; -} - -package Test::Harness::Iterator::FH; -sub next { - my $fh = $_[0]->{fh}; - return scalar <$fh>; -} - - -package Test::Harness::Iterator::ARRAY; -sub next { - my $self = shift; - return $self->{array}->[$self->{idx}++]; -} diff --git a/Perl/t/Test/Harness/Straps.pm b/Perl/t/Test/Harness/Straps.pm deleted file mode 100644 index 4d971b7..0000000 --- a/Perl/t/Test/Harness/Straps.pm +++ /dev/null @@ -1,667 +0,0 @@ -# -*- Mode: cperl; cperl-indent-level: 4 -*- -# $Id$ - -package Test::Harness::Straps; - -use strict; -use vars qw($VERSION); -use Config; -$VERSION = '0.15'; - -use Test::Harness::Assert; -use Test::Harness::Iterator; - -# Flags used as return values from our methods. Just for internal -# clarification. -my $TRUE = (1==1); -my $FALSE = !$TRUE; -my $YES = $TRUE; -my $NO = $FALSE; - - -=head1 NAME - -Test::Harness::Straps - detailed analysis of test results - -=head1 SYNOPSIS - - use Test::Harness::Straps; - - my $strap = Test::Harness::Straps->new; - - # Various ways to interpret a test - my %results = $strap->analyze($name, \@test_output); - my %results = $strap->analyze_fh($name, $test_filehandle); - my %results = $strap->analyze_file($test_file); - - # UNIMPLEMENTED - my %total = $strap->total_results; - - # Altering the behavior of the strap UNIMPLEMENTED - my $verbose_output = $strap->dump_verbose(); - $strap->dump_verbose_fh($output_filehandle); - - -=head1 DESCRIPTION - -B in that the interface is subject to change -in incompatible ways. It is otherwise stable. - -Test::Harness is limited to printing out its results. This makes -analysis of the test results difficult for anything but a human. To -make it easier for programs to work with test results, we provide -Test::Harness::Straps. Instead of printing the results, straps -provide them as raw data. You can also configure how the tests are to -be run. - -The interface is currently incomplete. I contact the author -if you'd like a feature added or something change or just have -comments. - -=head1 Construction - -=head2 C - - my $strap = Test::Harness::Straps->new; - -Initialize a new strap. - -=cut - -sub new { - my($proto) = shift; - my($class) = ref $proto || $proto; - - my $self = bless {}, $class; - $self->_init; - - return $self; -} - -=head2 C<_init> - - $strap->_init; - -Initialize the internal state of a strap to make it ready for parsing. - -=cut - -sub _init { - my($self) = shift; - - $self->{_is_vms} = $^O eq 'VMS'; - $self->{_is_win32} = $^O eq 'Win32'; -} - -=head1 Analysis - -=head2 C - - my %results = $strap->analyze($name, \@test_output); - -Analyzes the output of a single test, assigning it the given C<$name> -for use in the total report. Returns the C<%results> of the test. -See L. - -C<@test_output> should be the raw output from the test, including -newlines. - -=cut - -sub analyze { - my($self, $name, $test_output) = @_; - - my $it = Test::Harness::Iterator->new($test_output); - return $self->_analyze_iterator($name, $it); -} - - -sub _analyze_iterator { - my($self, $name, $it) = @_; - - $self->_reset_file_state; - $self->{file} = $name; - my %totals = ( - max => 0, - seen => 0, - - ok => 0, - todo => 0, - skip => 0, - bonus => 0, - - details => [] - ); - - # Set them up here so callbacks can have them. - $self->{totals}{$name} = \%totals; - while( defined(my $line = $it->next) ) { - $self->_analyze_line($line, \%totals); - last if $self->{saw_bailout}; - } - - $totals{skip_all} = $self->{skip_all} if defined $self->{skip_all}; - - my $passed = ($totals{max} == 0 && defined $totals{skip_all}) || - ($totals{max} && $totals{seen} && - $totals{max} == $totals{seen} && - $totals{max} == $totals{ok}); - $totals{passing} = $passed ? 1 : 0; - - return %totals; -} - - -sub _analyze_line { - my($self, $line, $totals) = @_; - - my %result = (); - - $self->{line}++; - - my $type; - if( $self->_is_header($line) ) { - $type = 'header'; - - $self->{saw_header}++; - - $totals->{max} += $self->{max}; - } - elsif( $self->_is_test($line, \%result) ) { - $type = 'test'; - - $totals->{seen}++; - $result{number} = $self->{'next'} unless $result{number}; - - # sometimes the 'not ' and the 'ok' are on different lines, - # happens often on VMS if you do: - # print "not " unless $test; - # print "ok $num\n"; - if( $self->{saw_lone_not} && - ($self->{lone_not_line} == $self->{line} - 1) ) - { - $result{ok} = 0; - } - - my $pass = $result{ok}; - $result{type} = 'todo' if $self->{todo}{$result{number}}; - - if( $result{type} eq 'todo' ) { - $totals->{todo}++; - $pass = 1; - $totals->{bonus}++ if $result{ok} - } - elsif( $result{type} eq 'skip' ) { - $totals->{skip}++; - $pass = 1; - } - - $totals->{ok}++ if $pass; - - if( $result{number} > 100000 && $result{number} > $self->{max} ) { - warn "Enormous test number seen [test $result{number}]\n"; - warn "Can't detailize, too big.\n"; - } - else { - $totals->{details}[$result{number} - 1] = - {$self->_detailize($pass, \%result)}; - } - - # XXX handle counter mismatch - } - elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) { - $type = 'bailout'; - $self->{saw_bailout} = 1; - } - else { - $type = 'other'; - } - - $self->{callback}->($self, $line, $type, $totals) if $self->{callback}; - - $self->{'next'} = $result{number} + 1 if $type eq 'test'; -} - -=head2 C - - my %results = $strap->analyze_fh($name, $test_filehandle); - -Like C, but it reads from the given filehandle. - -=cut - -sub analyze_fh { - my($self, $name, $fh) = @_; - - my $it = Test::Harness::Iterator->new($fh); - $self->_analyze_iterator($name, $it); -} - -=head2 C - - my %results = $strap->analyze_file($test_file); - -Like C, but it runs the given C<$test_file> and parses its -results. It will also use that name for the total report. - -=cut - -sub analyze_file { - my($self, $file) = @_; - - unless( -e $file ) { - $self->{error} = "$file does not exist"; - return; - } - - unless( -r $file ) { - $self->{error} = "$file is not readable"; - return; - } - - local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; - - my $cmd = $self->{_is_vms} ? "MCR $^X" : - $self->{_is_win32} ? Win32::GetShortPathName($^X) - : $^X; - - my $switches = $self->_switches($file); - - # *sigh* this breaks under taint, but open -| is unportable. - unless( open(FILE, "$cmd $switches $file|") ) { - print "can't run $file. $!\n"; - return; - } - - my %results = $self->analyze_fh($file, \*FILE); - my $exit = close FILE; - $results{'wait'} = $?; - if( $? && $self->{_is_vms} ) { - eval q{use vmsish "status"; $results{'exit'} = $?}; - } - else { - $results{'exit'} = _wait2exit($?); - } - $results{passing} = 0 unless $? == 0; - - $self->_restore_PERL5LIB(); - - return %results; -} - - -eval { require POSIX; &POSIX::WEXITSTATUS(0) }; -if( $@ ) { - *_wait2exit = sub { $_[0] >> 8 }; -} -else { - *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) } -} - - -=head2 C<_switches> - - my $switches = $self->_switches($file); - -Formats and returns the switches necessary to run the test. - -=cut - -sub _switches { - my($self, $file) = @_; - - local *TEST; - open(TEST, $file) or print "can't open $file. $!\n"; - my $first = ; - my $s = $Test::Harness::Switches || ''; - $s .= " $ENV{'HARNESS_PERL_SWITCHES'}" - if exists $ENV{'HARNESS_PERL_SWITCHES'}; - - if ($first =~ /^#!.*\bperl.*\s-\w*([Tt]+)/) { - # When taint mode is on, PERL5LIB is ignored. So we need to put - # all that on the command line as -Is. - $s .= join " ", qq[ "-$1"], map {qq["-I$_"]} $self->_filtered_INC; - } - elsif ($^O eq 'MacOS') { - # MacPerl's putenv is broken, so it will not see PERL5LIB. - $s .= join " ", map {qq["-I$_"]} $self->_filtered_INC; - } - - close(TEST) or print "can't close $file. $!\n"; - - return $s; -} - - -=head2 C<_INC2PERL5LIB> - - local $ENV{PERL5LIB} = $self->_INC2PERL5LIB; - -Takes the current value of C<@INC> and turns it into something suitable -for putting onto C. - -=cut - -sub _INC2PERL5LIB { - my($self) = shift; - - $self->{_old5lib} = $ENV{PERL5LIB}; - - return join $Config{path_sep}, $self->_filtered_INC; -} - -=head2 C<_filtered_INC> - - my @filtered_inc = $self->_filtered_INC; - -Shortens C<@INC> by removing redundant and unnecessary entries. -Necessary for OSes with limited command line lengths, like VMS. - -=cut - -sub _filtered_INC { - my($self, @inc) = @_; - @inc = @INC unless @inc; - - # VMS has a 255-byte limit on the length of %ENV entries, so - # toss the ones that involve perl_root, the install location - # for VMS - if( $self->{_is_vms} ) { - @inc = grep !/perl_root/i, @inc; - } - - return @inc; -} - - -=head2 C<_restore_PERL5LIB> - - $self->_restore_PERL5LIB; - -This restores the original value of the C environment variable. -Necessary on VMS, otherwise a no-op. - -=cut - -sub _restore_PERL5LIB { - my($self) = shift; - - return unless $self->{_is_vms}; - - if (defined $self->{_old5lib}) { - $ENV{PERL5LIB} = $self->{_old5lib}; - } -} - -=head1 Parsing - -Methods for identifying what sort of line you're looking at. - -=head2 C<_is_comment> - - my $is_comment = $strap->_is_comment($line, \$comment); - -Checks if the given line is a comment. If so, it will place it into -C<$comment> (sans #). - -=cut - -sub _is_comment { - my($self, $line, $comment) = @_; - - if( $line =~ /^\s*\#(.*)/ ) { - $$comment = $1; - return $YES; - } - else { - return $NO; - } -} - -=head2 C<_is_header> - - my $is_header = $strap->_is_header($line); - -Checks if the given line is a header (1..M) line. If so, it places how -many tests there will be in C<< $strap->{max} >>, a list of which tests -are todo in C<< $strap->{todo} >> and if the whole test was skipped -C<< $strap->{skip_all} >> contains the reason. - -=cut - -# Regex for parsing a header. Will be run with /x -my $Extra_Header_Re = <<'REGEX'; - ^ - (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set - (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason -REGEX - -sub _is_header { - my($self, $line) = @_; - - if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) { - $self->{max} = $max; - assert( $self->{max} >= 0, 'Max # of tests looks right' ); - - if( defined $extra ) { - my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo; - - $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo; - - if( $self->{max} == 0 ) { - $reason = '' unless defined $skip and $skip =~ /^Skip/i; - } - - $self->{skip_all} = $reason; - } - - return $YES; - } - else { - return $NO; - } -} - -=head2 C<_is_test> - - my $is_test = $strap->_is_test($line, \%test); - -Checks if the $line is a test report (ie. 'ok/not ok'). Reports the -result back in C<%test> which will contain: - - ok did it succeed? This is the literal 'ok' or 'not ok'. - name name of the test (if any) - number test number (if any) - - type 'todo' or 'skip' (if any) - reason why is it todo or skip? (if any) - -If will also catch lone 'not' lines, note it saw them -C<< $strap->{saw_lone_not} >> and the line in C<< $strap->{lone_not_line} >>. - -=cut - -my $Report_Re = <<'REGEX'; - ^ - (not\ )? # failure? - ok\b - (?:\s+(\d+))? # optional test number - \s* - (.*) # and the rest -REGEX - -my $Extra_Re = <<'REGEX'; - ^ - (.*?) (?:(?:[^\\]|^)# (.*))? - $ -REGEX - -sub _is_test { - my($self, $line, $test) = @_; - - # We pulverize the line down into pieces in three parts. - if( my($not, $num, $extra) = $line =~ /$Report_Re/ox ) { - my($name, $control) = split /(?:[^\\]|^)#/, $extra if $extra; - my($type, $reason) = $control =~ /^\s*(\S+)(?:\s+(.*))?$/ if $control; - - $test->{number} = $num; - $test->{ok} = $not ? 0 : 1; - $test->{name} = $name; - - if( defined $type ) { - $test->{type} = $type =~ /^TODO$/i ? 'todo' : - $type =~ /^Skip/i ? 'skip' : 0; - } - else { - $test->{type} = ''; - } - $test->{reason} = $reason; - - return $YES; - } - else{ - # Sometimes the "not " and "ok" will be on seperate lines on VMS. - # We catch this and remember we saw it. - if( $line =~ /^not\s+$/ ) { - $self->{saw_lone_not} = 1; - $self->{lone_not_line} = $self->{line}; - } - - return $NO; - } -} - -=head2 C<_is_bail_out> - - my $is_bail_out = $strap->_is_bail_out($line, \$reason); - -Checks if the line is a "Bail out!". Places the reason for bailing -(if any) in $reason. - -=cut - -sub _is_bail_out { - my($self, $line, $reason) = @_; - - if( $line =~ /^Bail out!\s*(.*)/i ) { - $$reason = $1 if $1; - return $YES; - } - else { - return $NO; - } -} - -=head2 C<_reset_file_state> - - $strap->_reset_file_state; - -Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>, -etc. so it's ready to parse the next file. - -=cut - -sub _reset_file_state { - my($self) = shift; - - delete @{$self}{qw(max skip_all todo)}; - $self->{line} = 0; - $self->{saw_header} = 0; - $self->{saw_bailout}= 0; - $self->{saw_lone_not} = 0; - $self->{lone_not_line} = 0; - $self->{bailout_reason} = ''; - $self->{'next'} = 1; -} - -=head1 Results - -The C<%results> returned from C contain the following -information: - - passing true if the whole test is considered a pass - (or skipped), false if its a failure - - exit the exit code of the test run, if from a file - wait the wait code of the test run, if from a file - - max total tests which should have been run - seen total tests actually seen - skip_all if the whole test was skipped, this will - contain the reason. - - ok number of tests which passed - (including todo and skips) - - todo number of todo tests seen - bonus number of todo tests which - unexpectedly passed - - skip number of tests skipped - -So a successful test should have max == seen == ok. - - -There is one final item, the details. - - details an array ref reporting the result of - each test looks like this: - - $results{details}[$test_num - 1] = - { ok => is the test considered ok? - actual_ok => did it literally say 'ok'? - name => name of the test (if any) - type => 'skip' or 'todo' (if any) - reason => reason for the above (if any) - }; - -Element 0 of the details is test #1. I tried it with element 1 being -#1 and 0 being empty, this is less awkward. - -=head2 C<_detailize> - - my %details = $strap->_detailize($pass, \%test); - -Generates the details based on the last test line seen. C<$pass> is -true if it was considered to be a passed test. C<%test> is the results -of the test you're summarizing. - -=cut - -sub _detailize { - my($self, $pass, $test) = @_; - - my %details = ( ok => $pass, - actual_ok => $test->{ok} - ); - - assert( !(grep !defined $details{$_}, keys %details), - 'test contains the ok and actual_ok info' ); - - # We don't want these to be undef because they are often - # checked and don't want the checker to have to deal with - # uninitialized vars. - foreach my $piece (qw(name type reason)) { - $details{$piece} = defined $test->{$piece} ? $test->{$piece} : ''; - } - - return %details; -} - -=head1 EXAMPLES - -See F for an example of use. - -=head1 AUTHOR - -Michael G Schwern C<< >>, currently maintained by -Andy Lester C<< >>. - -=head1 SEE ALSO - -L - -=cut - - -1; diff --git a/Perl/t/Test/More.pm b/Perl/t/Test/More.pm deleted file mode 100644 index 03f7552..0000000 --- a/Perl/t/Test/More.pm +++ /dev/null @@ -1,1248 +0,0 @@ -package Test::More; - -use 5.004; - -use strict; -use Test::Builder; - - -# Can't use Carp because it might cause use_ok() to accidentally succeed -# even though the module being used forgot to use Carp. Yes, this -# actually happened. -sub _carp { - my($file, $line) = (caller(1))[1,2]; - warn @_, " at $file line $line\n"; -} - - - -require Exporter; -use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); -$VERSION = '0.47'; -@ISA = qw(Exporter); -@EXPORT = qw(ok use_ok require_ok - is isnt like unlike is_deeply - cmp_ok - skip todo todo_skip - pass fail - eq_array eq_hash eq_set - $TODO - plan - can_ok isa_ok - diag - ); - -my $Test = Test::Builder->new; - - -# 5.004's Exporter doesn't have export_to_level. -sub _export_to_level -{ - my $pkg = shift; - my $level = shift; - (undef) = shift; # redundant arg - my $callpkg = caller($level); - $pkg->export($callpkg, @_); -} - - -=head1 NAME - -Test::More - yet another framework for writing test scripts - -=head1 SYNOPSIS - - use Test::More tests => $Num_Tests; - # or - use Test::More qw(no_plan); - # or - use Test::More skip_all => $reason; - - BEGIN { use_ok( 'Some::Module' ); } - require_ok( 'Some::Module' ); - - # Various ways to say "ok" - ok($this eq $that, $test_name); - - is ($this, $that, $test_name); - isnt($this, $that, $test_name); - - # Rather than print STDERR "# here's what went wrong\n" - diag("here's what went wrong"); - - like ($this, qr/that/, $test_name); - unlike($this, qr/that/, $test_name); - - cmp_ok($this, '==', $that, $test_name); - - is_deeply($complex_structure1, $complex_structure2, $test_name); - - SKIP: { - skip $why, $how_many unless $have_some_feature; - - ok( foo(), $test_name ); - is( foo(42), 23, $test_name ); - }; - - TODO: { - local $TODO = $why; - - ok( foo(), $test_name ); - is( foo(42), 23, $test_name ); - }; - - can_ok($module, @methods); - isa_ok($object, $class); - - pass($test_name); - fail($test_name); - - # Utility comparison functions. - eq_array(\@this, \@that); - eq_hash(\%this, \%that); - eq_set(\@this, \@that); - - # UNIMPLEMENTED!!! - my @status = Test::More::status; - - # UNIMPLEMENTED!!! - BAIL_OUT($why); - - -=head1 DESCRIPTION - -B If you're just getting started writing tests, have a look at -Test::Simple first. This is a drop in replacement for Test::Simple -which you can switch to once you get the hang of basic testing. - -The purpose of this module is to provide a wide range of testing -utilities. Various ways to say "ok" with better diagnostics, -facilities to skip tests, test future features and compare complicated -data structures. While you can do almost anything with a simple -C function, it doesn't provide good diagnostic output. - - -=head2 I love it when a plan comes together - -Before anything else, you need a testing plan. This basically declares -how many tests your script is going to run to protect against premature -failure. - -The preferred way to do this is to declare a plan when you C. - - use Test::More tests => $Num_Tests; - -There are rare cases when you will not know beforehand how many tests -your script is going to run. In this case, you can declare that you -have no plan. (Try to avoid using this as it weakens your test.) - - use Test::More qw(no_plan); - -In some cases, you'll want to completely skip an entire testing script. - - use Test::More skip_all => $skip_reason; - -Your script will declare a skip with the reason why you skipped and -exit immediately with a zero (success). See L for -details. - -If you want to control what functions Test::More will export, you -have to use the 'import' option. For example, to import everything -but 'fail', you'd do: - - use Test::More tests => 23, import => ['!fail']; - -Alternatively, you can use the plan() function. Useful for when you -have to calculate the number of tests. - - use Test::More; - plan tests => keys %Stuff * 3; - -or for deciding between running the tests at all: - - use Test::More; - if( $^O eq 'MacOS' ) { - plan skip_all => 'Test irrelevant on MacOS'; - } - else { - plan tests => 42; - } - -=cut - -sub plan { - my(@plan) = @_; - - my $caller = caller; - - $Test->exported_to($caller); - - my @imports = (); - foreach my $idx (0..$#plan) { - if( $plan[$idx] eq 'import' ) { - my($tag, $imports) = splice @plan, $idx, 2; - @imports = @$imports; - last; - } - } - - $Test->plan(@plan); - - __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); -} - -sub import { - my($class) = shift; - goto &plan; -} - - -=head2 Test names - -By convention, each test is assigned a number in order. This is -largely done automatically for you. However, it's often very useful to -assign a name to each test. Which would you rather see: - - ok 4 - not ok 5 - ok 6 - -or - - ok 4 - basic multi-variable - not ok 5 - simple exponential - ok 6 - force == mass * acceleration - -The later gives you some idea of what failed. It also makes it easier -to find the test in your script, simply search for "simple -exponential". - -All test functions take a name argument. It's optional, but highly -suggested that you use it. - - -=head2 I'm ok, you're not ok. - -The basic purpose of this module is to print out either "ok #" or "not -ok #" depending on if a given test succeeded or failed. Everything -else is just gravy. - -All of the following print "ok" or "not ok" depending on if the test -succeeded or failed. They all also return true or false, -respectively. - -=over 4 - -=item B - - ok($this eq $that, $test_name); - -This simply evaluates any expression (C<$this eq $that> is just a -simple example) and uses that to determine if the test succeeded or -failed. A true expression passes, a false one fails. Very simple. - -For example: - - ok( $exp{9} == 81, 'simple exponential' ); - ok( Film->can('db_Main'), 'set_db()' ); - ok( $p->tests == 4, 'saw tests' ); - ok( !grep !defined $_, @items, 'items populated' ); - -(Mnemonic: "This is ok.") - -$test_name is a very short description of the test that will be printed -out. It makes it very easy to find a test in your script when it fails -and gives others an idea of your intentions. $test_name is optional, -but we B strongly encourage its use. - -Should an ok() fail, it will produce some diagnostics: - - not ok 18 - sufficient mucus - # Failed test 18 (foo.t at line 42) - -This is actually Test::Simple's ok() routine. - -=cut - -sub ok ($;$) { - my($test, $name) = @_; - $Test->ok($test, $name); -} - -=item B - -=item B - - is ( $this, $that, $test_name ); - isnt( $this, $that, $test_name ); - -Similar to ok(), is() and isnt() compare their two arguments -with C and C respectively and use the result of that to -determine if the test succeeded or failed. So these: - - # Is the ultimate answer 42? - is( ultimate_answer(), 42, "Meaning of Life" ); - - # $foo isn't empty - isnt( $foo, '', "Got some foo" ); - -are similar to these: - - ok( ultimate_answer() eq 42, "Meaning of Life" ); - ok( $foo ne '', "Got some foo" ); - -(Mnemonic: "This is that." "This isn't that.") - -So why use these? They produce better diagnostics on failure. ok() -cannot know what you are testing for (beyond the name), but is() and -isnt() know what the test was and why it failed. For example this -test: - - my $foo = 'waffle'; my $bar = 'yarblokos'; - is( $foo, $bar, 'Is foo the same as bar?' ); - -Will produce something like this: - - not ok 17 - Is foo the same as bar? - # Failed test (foo.t at line 139) - # got: 'waffle' - # expected: 'yarblokos' - -So you can figure out what went wrong without rerunning the test. - -You are encouraged to use is() and isnt() over ok() where possible, -however do not be tempted to use them to find out if something is -true or false! - - # XXX BAD! $pope->isa('Catholic') eq 1 - is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' ); - -This does not check if C<$pope->isa('Catholic')> is true, it checks if -it returns 1. Very different. Similar caveats exist for false and 0. -In these cases, use ok(). - - ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' ); - -For those grammatical pedants out there, there's an C -function which is an alias of isnt(). - -=cut - -sub is ($$;$) { - $Test->is_eq(@_); -} - -sub isnt ($$;$) { - $Test->isnt_eq(@_); -} - -*isn't = \&isnt; - - -=item B - - like( $this, qr/that/, $test_name ); - -Similar to ok(), like() matches $this against the regex C. - -So this: - - like($this, qr/that/, 'this is like that'); - -is similar to: - - ok( $this =~ /that/, 'this is like that'); - -(Mnemonic "This is like that".) - -The second argument is a regular expression. It may be given as a -regex reference (i.e. C) or (for better compatibility with older -perls) as a string that looks like a regex (alternative delimiters are -currently not supported): - - like( $this, '/that/', 'this is like that' ); - -Regex options may be placed on the end (C<'/that/i'>). - -Its advantages over ok() are similar to that of is() and isnt(). Better -diagnostics on failure. - -=cut - -sub like ($$;$) { - $Test->like(@_); -} - - -=item B - - unlike( $this, qr/that/, $test_name ); - -Works exactly as like(), only it checks if $this B match the -given pattern. - -=cut - -sub unlike { - $Test->unlike(@_); -} - - -=item B - - cmp_ok( $this, $op, $that, $test_name ); - -Halfway between ok() and is() lies cmp_ok(). This allows you to -compare two arguments using any binary perl operator. - - # ok( $this eq $that ); - cmp_ok( $this, 'eq', $that, 'this eq that' ); - - # ok( $this == $that ); - cmp_ok( $this, '==', $that, 'this == that' ); - - # ok( $this && $that ); - cmp_ok( $this, '&&', $that, 'this || that' ); - ...etc... - -Its advantage over ok() is when the test fails you'll know what $this -and $that were: - - not ok 1 - # Failed test (foo.t at line 12) - # '23' - # && - # undef - -It's also useful in those cases where you are comparing numbers and -is()'s use of C will interfere: - - cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); - -=cut - -sub cmp_ok($$$;$) { - $Test->cmp_ok(@_); -} - - -=item B - - can_ok($module, @methods); - can_ok($object, @methods); - -Checks to make sure the $module or $object can do these @methods -(works with functions, too). - - can_ok('Foo', qw(this that whatever)); - -is almost exactly like saying: - - ok( Foo->can('this') && - Foo->can('that') && - Foo->can('whatever') - ); - -only without all the typing and with a better interface. Handy for -quickly testing an interface. - -No matter how many @methods you check, a single can_ok() call counts -as one test. If you desire otherwise, use: - - foreach my $meth (@methods) { - can_ok('Foo', $meth); - } - -=cut - -sub can_ok ($@) { - my($proto, @methods) = @_; - my $class = ref $proto || $proto; - - unless( @methods ) { - my $ok = $Test->ok( 0, "$class->can(...)" ); - $Test->diag(' can_ok() called with no methods'); - return $ok; - } - - my @nok = (); - foreach my $method (@methods) { - local($!, $@); # don't interfere with caller's $@ - # eval sometimes resets $! - eval { $proto->can($method) } || push @nok, $method; - } - - my $name; - $name = @methods == 1 ? "$class->can('$methods[0]')" - : "$class->can(...)"; - - my $ok = $Test->ok( !@nok, $name ); - - $Test->diag(map " $class->can('$_') failed\n", @nok); - - return $ok; -} - -=item B - - isa_ok($object, $class, $object_name); - isa_ok($ref, $type, $ref_name); - -Checks to see if the given $object->isa($class). Also checks to make -sure the object was defined in the first place. Handy for this sort -of thing: - - my $obj = Some::Module->new; - isa_ok( $obj, 'Some::Module' ); - -where you'd otherwise have to write - - my $obj = Some::Module->new; - ok( defined $obj && $obj->isa('Some::Module') ); - -to safeguard against your test script blowing up. - -It works on references, too: - - isa_ok( $array_ref, 'ARRAY' ); - -The diagnostics of this test normally just refer to 'the object'. If -you'd like them to be more specific, you can supply an $object_name -(for example 'Test customer'). - -=cut - -sub isa_ok ($$;$) { - my($object, $class, $obj_name) = @_; - - my $diag; - $obj_name = 'The object' unless defined $obj_name; - my $name = "$obj_name isa $class"; - if( !defined $object ) { - $diag = "$obj_name isn't defined"; - } - elsif( !ref $object ) { - $diag = "$obj_name isn't a reference"; - } - else { - # We can't use UNIVERSAL::isa because we want to honor isa() overrides - local($@, $!); # eval sometimes resets $! - my $rslt = eval { $object->isa($class) }; - if( $@ ) { - if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { - if( !UNIVERSAL::isa($object, $class) ) { - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; - } - } else { - die <isa on your object and got some weird error. -This should never happen. Please contact the author immediately. -Here's the error. -$@ -WHOA - } - } - elsif( !$rslt ) { - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; - } - } - - - - my $ok; - if( $diag ) { - $ok = $Test->ok( 0, $name ); - $Test->diag(" $diag\n"); - } - else { - $ok = $Test->ok( 1, $name ); - } - - return $ok; -} - - -=item B - -=item B - - pass($test_name); - fail($test_name); - -Sometimes you just want to say that the tests have passed. Usually -the case is you've got some complicated condition that is difficult to -wedge into an ok(). In this case, you can simply use pass() (to -declare the test ok) or fail (for not ok). They are synonyms for -ok(1) and ok(0). - -Use these very, very, very sparingly. - -=cut - -sub pass (;$) { - $Test->ok(1, @_); -} - -sub fail (;$) { - $Test->ok(0, @_); -} - -=back - -=head2 Diagnostics - -If you pick the right test function, you'll usually get a good idea of -what went wrong when it failed. But sometimes it doesn't work out -that way. So here we have ways for you to write your own diagnostic -messages which are safer than just C. - -=over 4 - -=item B - - diag(@diagnostic_message); - -Prints a diagnostic message which is guaranteed not to interfere with -test output. Handy for this sort of thing: - - ok( grep(/foo/, @users), "There's a foo user" ) or - diag("Since there's no foo, check that /etc/bar is set up right"); - -which would produce: - - not ok 42 - There's a foo user - # Failed test (foo.t at line 52) - # Since there's no foo, check that /etc/bar is set up right. - -You might remember C with the mnemonic C. - -B The exact formatting of the diagnostic output is still -changing, but it is guaranteed that whatever you throw at it it won't -interfere with the test. - -=cut - -sub diag { - $Test->diag(@_); -} - - -=back - -=head2 Module tests - -You usually want to test if the module you're testing loads ok, rather -than just vomiting if its load fails. For such purposes we have -C and C. - -=over 4 - -=item B - - BEGIN { use_ok($module); } - BEGIN { use_ok($module, @imports); } - -These simply use the given $module and test to make sure the load -happened ok. It's recommended that you run use_ok() inside a BEGIN -block so its functions are exported at compile-time and prototypes are -properly honored. - -If @imports are given, they are passed through to the use. So this: - - BEGIN { use_ok('Some::Module', qw(foo bar)) } - -is like doing this: - - use Some::Module qw(foo bar); - -don't try to do this: - - BEGIN { - use_ok('Some::Module'); - - ...some code that depends on the use... - ...happening at compile time... - } - -instead, you want: - - BEGIN { use_ok('Some::Module') } - BEGIN { ...some code that depends on the use... } - - -=cut - -sub use_ok ($;@) { - my($module, @imports) = @_; - @imports = () unless @imports; - - my $pack = caller; - - local($@,$!); # eval sometimes interferes with $! - eval <import(\@imports); -USE - - my $ok = $Test->ok( !$@, "use $module;" ); - - unless( $ok ) { - chomp $@; - $Test->diag(< - - require_ok($module); - -Like use_ok(), except it requires the $module. - -=cut - -sub require_ok ($) { - my($module) = shift; - - my $pack = caller; - - local($!, $@); # eval sometimes interferes with $! - eval <ok( !$@, "require $module;" ); - - unless( $ok ) { - chomp $@; - $Test->diag(<. - -The way Test::More handles this is with a named block. Basically, a -block of tests which can be skipped over or made todo. It's best if I -just show you... - -=over 4 - -=item B - - SKIP: { - skip $why, $how_many if $condition; - - ...normal testing code goes here... - } - -This declares a block of tests that might be skipped, $how_many tests -there are, $why and under what $condition to skip them. An example is -the easiest way to illustrate: - - SKIP: { - eval { require HTML::Lint }; - - skip "HTML::Lint not installed", 2 if $@; - - my $lint = new HTML::Lint; - isa_ok( $lint, "HTML::Lint" ); - - $lint->parse( $html ); - is( $lint->errors, 0, "No errors found in HTML" ); - } - -If the user does not have HTML::Lint installed, the whole block of -code I. Test::More will output special ok's -which Test::Harness interprets as skipped, but passing, tests. -It's important that $how_many accurately reflects the number of tests -in the SKIP block so the # of tests run will match up with your plan. - -It's perfectly safe to nest SKIP blocks. Each SKIP block must have -the label C, or Test::More can't work its magic. - -You don't skip tests which are failing because there's a bug in your -program, or for which you don't yet have code written. For that you -use TODO. Read on. - -=cut - -#'# -sub skip { - my($why, $how_many) = @_; - - unless( defined $how_many ) { - # $how_many can only be avoided when no_plan is in use. - _carp "skip() needs to know \$how_many tests are in the block" - unless $Test::Builder::No_Plan; - $how_many = 1; - } - - for( 1..$how_many ) { - $Test->skip($why); - } - - local $^W = 0; - last SKIP; -} - - -=item B - - TODO: { - local $TODO = $why if $condition; - - ...normal testing code goes here... - } - -Declares a block of tests you expect to fail and $why. Perhaps it's -because you haven't fixed a bug or haven't finished a new feature: - - TODO: { - local $TODO = "URI::Geller not finished"; - - my $card = "Eight of clubs"; - is( URI::Geller->your_card, $card, 'Is THIS your card?' ); - - my $spoon; - URI::Geller->bend_spoon; - is( $spoon, 'bent', "Spoon bending, that's original" ); - } - -With a todo block, the tests inside are expected to fail. Test::More -will run the tests normally, but print out special flags indicating -they are "todo". Test::Harness will interpret failures as being ok. -Should anything succeed, it will report it as an unexpected success. -You then know the thing you had todo is done and can remove the -TODO flag. - -The nice part about todo tests, as opposed to simply commenting out a -block of tests, is it's like having a programmatic todo list. You know -how much work is left to be done, you're aware of what bugs there are, -and you'll know immediately when they're fixed. - -Once a todo test starts succeeding, simply move it outside the block. -When the block is empty, delete it. - - -=item B - - TODO: { - todo_skip $why, $how_many if $condition; - - ...normal testing code... - } - -With todo tests, it's best to have the tests actually run. That way -you'll know when they start passing. Sometimes this isn't possible. -Often a failing test will cause the whole program to die or hang, even -inside an C with and using C. In these extreme -cases you have no choice but to skip over the broken tests entirely. - -The syntax and behavior is similar to a C except the -tests will be marked as failing but todo. Test::Harness will -interpret them as passing. - -=cut - -sub todo_skip { - my($why, $how_many) = @_; - - unless( defined $how_many ) { - # $how_many can only be avoided when no_plan is in use. - _carp "todo_skip() needs to know \$how_many tests are in the block" - unless $Test::Builder::No_Plan; - $how_many = 1; - } - - for( 1..$how_many ) { - $Test->todo_skip($why); - } - - local $^W = 0; - last TODO; -} - -=item When do I use SKIP vs. TODO? - -B, use SKIP. -This includes optional modules that aren't installed, running under -an OS that doesn't have some feature (like fork() or symlinks), or maybe -you need an Internet connection and one isn't available. - -B, use TODO. This -is for any code you haven't written yet, or bugs you have yet to fix, -but want to put tests in your testing script (always a good idea). - - -=back - -=head2 Comparison functions - -Not everything is a simple eq check or regex. There are times you -need to see if two arrays are equivalent, for instance. For these -instances, Test::More provides a handful of useful functions. - -B These are NOT well-tested on circular references. Nor am I -quite sure what will happen with filehandles. - -=over 4 - -=item B - - is_deeply( $this, $that, $test_name ); - -Similar to is(), except that if $this and $that are hash or array -references, it does a deep comparison walking each data structure to -see if they are equivalent. If the two structures are different, it -will display the place where they start differing. - -Barrie Slaymaker's Test::Differences module provides more in-depth -functionality along these lines, and it plays well with Test::More. - -B Display of scalar refs is not quite 100% - -=cut - -use vars qw(@Data_Stack); -my $DNE = bless [], 'Does::Not::Exist'; -sub is_deeply { - my($this, $that, $name) = @_; - - my $ok; - if( !ref $this || !ref $that ) { - $ok = $Test->is_eq($this, $that, $name); - } - else { - local @Data_Stack = (); - if( _deep_check($this, $that) ) { - $ok = $Test->ok(1, $name); - } - else { - $ok = $Test->ok(0, $name); - $ok = $Test->diag(_format_stack(@Data_Stack)); - } - } - - return $ok; -} - -sub _format_stack { - my(@Stack) = @_; - - my $var = '$FOO'; - my $did_arrow = 0; - foreach my $entry (@Stack) { - my $type = $entry->{type} || ''; - my $idx = $entry->{'idx'}; - if( $type eq 'HASH' ) { - $var .= "->" unless $did_arrow++; - $var .= "{$idx}"; - } - elsif( $type eq 'ARRAY' ) { - $var .= "->" unless $did_arrow++; - $var .= "[$idx]"; - } - elsif( $type eq 'REF' ) { - $var = "\${$var}"; - } - } - - my @vals = @{$Stack[-1]{vals}}[0,1]; - my @vars = (); - ($vars[0] = $var) =~ s/\$FOO/ \$got/; - ($vars[1] = $var) =~ s/\$FOO/\$expected/; - - my $out = "Structures begin differing at:\n"; - foreach my $idx (0..$#vals) { - my $val = $vals[$idx]; - $vals[$idx] = !defined $val ? 'undef' : - $val eq $DNE ? "Does not exist" - : "'$val'"; - } - - $out .= "$vars[0] = $vals[0]\n"; - $out .= "$vars[1] = $vals[1]\n"; - - $out =~ s/^/ /msg; - return $out; -} - - -=item B - - eq_array(\@this, \@that); - -Checks if two arrays are equivalent. This is a deep check, so -multi-level structures are handled correctly. - -=cut - -#'# -sub eq_array { - my($a1, $a2) = @_; - return 1 if $a1 eq $a2; - - my $ok = 1; - my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; - for (0..$max) { - my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; - my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; - - push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; - $ok = _deep_check($e1,$e2); - pop @Data_Stack if $ok; - - last unless $ok; - } - return $ok; -} - -sub _deep_check { - my($e1, $e2) = @_; - my $ok = 0; - -# my $eq; - { - # Quiet uninitialized value warnings when comparing undefs. - local $^W = 0; - - if( $e1 eq $e2 ) { - $ok = 1; - } - else { - if( UNIVERSAL::isa($e1, 'ARRAY') and - UNIVERSAL::isa($e2, 'ARRAY') ) - { - $ok = eq_array($e1, $e2); - } - elsif( UNIVERSAL::isa($e1, 'HASH') and - UNIVERSAL::isa($e2, 'HASH') ) - { - $ok = eq_hash($e1, $e2); - } - elsif( UNIVERSAL::isa($e1, 'REF') and - UNIVERSAL::isa($e2, 'REF') ) - { - push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; - $ok = _deep_check($$e1, $$e2); - pop @Data_Stack if $ok; - } - elsif( UNIVERSAL::isa($e1, 'SCALAR') and - UNIVERSAL::isa($e2, 'SCALAR') ) - { - push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; - $ok = _deep_check($$e1, $$e2); - } - else { - push @Data_Stack, { vals => [$e1, $e2] }; - $ok = 0; - } - } - } - - return $ok; -} - - -=item B - - eq_hash(\%this, \%that); - -Determines if the two hashes contain the same keys and values. This -is a deep check. - -=cut - -sub eq_hash { - my($a1, $a2) = @_; - return 1 if $a1 eq $a2; - - my $ok = 1; - my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; - foreach my $k (keys %$bigger) { - my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; - my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; - - push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; - $ok = _deep_check($e1, $e2); - pop @Data_Stack if $ok; - - last unless $ok; - } - - return $ok; -} - -=item B - - eq_set(\@this, \@that); - -Similar to eq_array(), except the order of the elements is B -important. This is a deep check, but the irrelevancy of order only -applies to the top level. - -B By historical accident, this is not a true set comparision. -While the order of elements does not matter, duplicate elements do. - -=cut - -# We must make sure that references are treated neutrally. It really -# doesn't matter how we sort them, as long as both arrays are sorted -# with the same algorithm. -sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b } - -sub eq_set { - my($a1, $a2) = @_; - return 0 unless @$a1 == @$a2; - - # There's faster ways to do this, but this is easiest. - return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); -} - -=back - - -=head2 Extending and Embedding Test::More - -Sometimes the Test::More interface isn't quite enough. Fortunately, -Test::More is built on top of Test::Builder which provides a single, -unified backend for any test library to use. This means two test -libraries which both use Test::Builder B. - -If you simply want to do a little tweaking of how the tests behave, -you can access the underlying Test::Builder object like so: - -=over 4 - -=item B - - my $test_builder = Test::More->builder; - -Returns the Test::Builder object underlying Test::More for you to play -with. - -=cut - -sub builder { - return Test::Builder->new; -} - -=back - - -=head1 NOTES - -Test::More is B tested all the way back to perl 5.004. - -Test::More is thread-safe for perl 5.8.0 and up. - -=head1 BUGS and CAVEATS - -=over 4 - -=item Making your own ok() - -If you are trying to extend Test::More, don't. Use Test::Builder -instead. - -=item The eq_* family has some caveats. - -=item Test::Harness upgrades - -no_plan and todo depend on new Test::Harness features and fixes. If -you're going to distribute tests that use no_plan or todo your -end-users will have to upgrade Test::Harness to the latest one on -CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness -will work fine. - -If you simply depend on Test::More, it's own dependencies will cause a -Test::Harness upgrade. - -=back - - -=head1 HISTORY - -This is a case of convergent evolution with Joshua Pritikin's Test -module. I was largely unaware of its existence when I'd first -written my own ok() routines. This module exists because I can't -figure out how to easily wedge test names into Test's interface (along -with a few other problems). - -The goal here is to have a testing utility that's simple to learn, -quick to use and difficult to trip yourself up with while still -providing more flexibility than the existing Test.pm. As such, the -names of the most common routines are kept tiny, special cases and -magic side-effects are kept to a minimum. WYSIWYG. - - -=head1 SEE ALSO - -L if all this confuses you and you just want to write -some tests. You can upgrade to Test::More later (it's forward -compatible). - -L for more ways to test complex data structures. -And it plays well with Test::More. - -L is the old testing module. Its main benefit is that it has -been distributed with Perl since 5.004_05. - -L for details on how your test results are interpreted -by Perl. - -L describes a very featureful unit testing interface. - -L shows the idea of embedded testing. - -L is another approach to embedded testing. - - -=head1 AUTHORS - -Michael G Schwern Eschwern@pobox.comE with much inspiration -from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, chromatic and the perl-qa gang. - - -=head1 COPYRIGHT - -Copyright 2001 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut - -1; diff --git a/Perl/t/TestLog.pm b/Perl/t/TestLog.pm deleted file mode 100644 index 6c84604..0000000 --- a/Perl/t/TestLog.pm +++ /dev/null @@ -1,306 +0,0 @@ -package TestLog; - -# $Id$ -# These test facilities has been developped by C. Mertz - -use IO::Handle; # for autoflushing the logs -use Carp; - -use Exporter; -@ISA = qw(Exporter); - -use vars qw( $VERSION @ISA); -($VERSION) = sprintf("%d.%02d", q$Revision$ =~ /(\d+)\.(\d+)/); -@EXPORT = qw( openLog setZincLog log test_eval test_no_eval printableItem printableArray printableList - equal_flat_arrays nequal_cplx_arrays); -use strict; - -use constant ERROR => '--an error--'; - -my $selected_loglevel; - -sub openLog { - my ($outfile, $loglevel, $no_logfile) = @_; - - $selected_loglevel = $loglevel; - if (defined $no_logfile && $no_logfile) { - open LOG, "> /dev/null"; - } - else { - if ( open LOG, "$outfile.prev" ) { - close LOG; - unlink "$outfile.prev"; - } - if ( open LOG, $outfile ) { - close LOG; - link $outfile, "$outfile.prev"; - unlink "$outfile"; - } - - open LOG,"> $outfile"; - autoflush LOG 1; # autoflush is important so that logs are up-to-date if Zinc crashes! - } -} - - - -### print log information to the logfile -### if $level is <= than selected_loglevel (def = 0) then print log on the stdout -### - a loglevel of -100 means an error to be logged with #### prefix -### - a loglevel of -10 means an error in the test to be logged with ## prefix -### - a loglevel of 0 means an message to be usually printed (and logged in any case) -### - a loglevel greater than 1 is for trace only - - -sub log { - my ($loglevel, @strgs) = @_; - if ($loglevel <= $selected_loglevel) { - print "#### " if $loglevel == -100; - print "## " if $loglevel == -10; - print @strgs; - } - print LOG "#### " if $loglevel == -100; - print LOG "## " if $loglevel == -10; - print LOG @strgs; -} # end log - -my $zinc; -## to init the $zinc -sub setZincLog { - ($zinc)=@_; -} - - -my %method_with_tagOrId = - ("anchorxy" => 1, "bbox" => 1, "bind" => 1, "chggroup" => 1, - "clone" => 1, "contour" => 1, "coords"=> 1, "cursor" => 1, - "dchars" => 1, "dtag" => 1, "focus" => 1, "gettags" => 1, - "group" => 1, # blabla... to complete - "itemcget" => 1, "itemconfigure" => 1, # blabla... to complete - "remove" => 1, - ); - -### evaluate $zinc->$method(@args); and verifies that NO ERROR occurs -### - a loglevel of -100 means an error to be logged with #### prefix -### - a loglevel of -10 means an error in the test, to be logged with ## -### - a loglevel of of 0 or greater is for trace only (usefull when an error occurs) -sub test_eval { - my ($loglevel, $method, @args) = @_; - - my @strs; - my $start_index = 0; - my $string2log = "\$zinc->$method ("; - if (scalar @args) { - if ($method_with_tagOrId{$method} and $args[0] =~ /^\d+$/) { - my $type = $zinc->type($args[0]); - $string2log .= &printableItem($args[0]) . " (a". ucfirst($type) . ")"; - } else { - $string2log .= &printableItem($args[0]) ; - } - $string2log .= ", " if $#args > 0 ; - my $rest = &printableList(@args[1..$#args]); - $rest =~ s/^\(//; ### suppressing the first ( char - $string2log .= $rest; - } else { - $string2log .= ")"; - } - if ($method eq 'itemcget' or $method eq 'get') { - $string2log .= "; # := " ; - } else { - $string2log .= ";\n"; - } - &log ($loglevel, $string2log); - - my (@res, $res); - if (wantarray()) { - @res = eval { $zinc->$method (@args) } ; - if ($method eq 'itemcget' or $method eq 'get') { - &log ($loglevel, printableList(@res) . "\n" ); - } - } else { - $res = eval { $zinc->$method (@args) } ; - if ($method eq 'itemcget' or $method eq 'get') { - &log ($loglevel, &printableItem($res) . "\n"); - } - } - - if ($@) { # in case of error, logging! - &log (-100, "Error while evaluating: $string2log;"); - &log (-100, $@); - my $msgl = &Carp::longmess; - my ($msg2) = $msgl =~ /.*?( at .*)/s ; - &log (-100, "\t$msg2"); - return (ERROR); - } else { - if (wantarray()) { - return @res; - } - else { - return $res; - } - } -} # end of test_eval - -### evaluate $zinc->$method(@args); and verifies that AN ERROR occurs -### - a loglevel of -100 means an NO error to be loggued with #### prefix -### - a loglevel of -10 means NO error in the test to be loggued with ## prefix -### - a loglevel of of 0 or greater is for trace only if NO error occured -sub test_no_eval { - my ($reason, $loglevel, $method, @args) = @_; - - my @strs; - my $start_index = 0; - my $string2log = "\$zinc->$method ("; - if (scalar @args) { - if ($method_with_tagOrId{$method} and $args[0] =~ /^\d+$/) { - my $type = $zinc->type($args[0]); - $string2log .= &printableItem($args[0]) . " (a". ucfirst($type) . ")"; - } else { - $string2log .= &printableItem($args[0]) ; - } - $string2log .= ", " if $#args > 0 ; - my $rest = &printableList(@args[1..$#args]); - $rest =~ s/^\(//; ### suppressing the first ( char - $string2log .= $rest; - } else { - $string2log .= ")"; - } - - eval { $zinc->$method (@args) } ; - - # in case of NO error, logging! - if ($@) { -# print "errormsg=$@"; - my ($error_msg) = $@ =~ /(.*)\s*at \/usr\//; - $error_msg = $@ if !defined $error_msg ; - &log ($loglevel, " # When $reason : $string2log;\n # the error msg is: $error_msg\n"); - } else { - &log (-100, "An error SHOULD have occured while evaluating:\n####\t$string2log;\n####\tbecause $reason\n"); - } -} # end of test_no_eval - - -### return a printable string of something in a readable form -sub printableItem { - my ($value) = @_; - my $ref = ref($value); - if ($ref eq 'ARRAY') { - return printableArray ( @{$value} ); - } - elsif ($ref eq 'Tk::Photo') { - return 'Tk::Photo("'. $value->cget(-file) . '")'; - } - elsif ($ref eq '') { # scalar - if (defined $value) { - if ($value eq '') { - return "''"; - } elsif ($value =~ /^-[a-zA-Z_]+$/) { - ## for the -attribut - return $value; - } elsif ($value =~ /\s/ - or $value =~ /[a-zA-Z]/ - or $value =~ /^[\W]$/ ) { - return "'$value'"; - } else { - return $value; - } - } - else { - return "undef"; - } - } - else { # some class instance - return $value; - } -} # end printableItem - -### to print an array of something -sub printableArray { - my (@values) = @_; - if (! scalar @values) { - return "[]"; - } - else { # the array is not empty - my $res = "[ "; - while (@values) { - my $value = shift @values; - $res .= &printableItem($value); - next unless (@values); - if ($value =~ /^-\w+/) { - $res .= " => "; - } elsif (@_) { - $res .= ", "; - } - - } - return ($res . " ]") ; - } -} # end printableArray - -sub printableList { - my $res = "("; - while (@_) { - my $v = shift @_; - $res .= &printableItem($v); - if (defined $v and $v =~ /^-\w+/ and @_) { - $res .= " => "; - } elsif (@_) { - $res .= ", "; - } - } - return $res . ")"; -} # end printableList - - -## return 1 if arrays of scalars have the same length and every items are eq -sub equal_flat_arrays { - my ($refArray1, $refArray2) = @_; - my @array1 = @{$refArray1}; - my @array2 = @{$refArray2}; - - return 0 if ($#array1 != $#array2); - - for my $i (0..$#array1) { - return 0 if ($array1[$i] ne $array2[$i]); - } - return 1; -} # equal_arrays - - -## return 0 if arrays of anything are equal -## return 'length' if their length are different -## return xx if some elements are différents -## arrays may be arrays of arrays of arrays ... -sub nequal_cplx_arrays { - my ($refArray1, $refArray2) = @_; - my @array1 = @{$refArray1}; - my @array2 = @{$refArray2}; - -# print "array1=", &printableArray(@array1), "\narray2=",&printableArray(@array2),"\n"; - return 'length' if ($#array1 != $#array2); - - for my $i (0..$#array1) { - my $el1 = $array1[$i]; - my $el2 = $array2[$i]; - - if (ref($el1)) { -# print "REF el1=",ref($el1),"\n"; - if (!ref($el2)) { - return "elts at index $i are different: $el1 != $el2\n"; - } elsif (ref($el2) ne ref($el1)) { - return "elts at index $i are of different type: ". - ref($el2), " ne ", ref($el1), "\n"; - } elsif (ref($el2) eq 'ARRAY') { - if (my $res = &nequal_cplx_arrays ($el1,$el2)) { - return "elts at index $i are different: $res"; - } - } - } elsif (ref($el2) or $el1 ne $el2) { - return "elts at index $i are different $el1 != $el2\n"; - } - } - return 0; -} # nequal_cplx_arrays - - -1; diff --git a/Perl/t/Text.t b/Perl/t/Text.t deleted file mode 100644 index bd43a4b..0000000 --- a/Perl/t/Text.t +++ /dev/null @@ -1,58 +0,0 @@ -#!/usr/bin/perl -w - -# -# $Id: Text.t,v 1.2 2004-04-02 12:01:49 mertz Exp $ -# Author: Christophe Mertz -# - -# testing all the import - -BEGIN { - if (!eval q{ -# use Test::More qw(no_plan); - use Test::More tests => 5; - 1; - }) { - print "# tests only work properly with installed Test::More module\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - use Tk::Zinc; - 1; - }) { - print "unable to load Tk::Zinc"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - MainWindow->new(); - 1; - }) { - print "# tests only work properly when it is possible to create a mainwindow in your env\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } -} - - -$mw = MainWindow->new(); -$zinc = $mw->Zinc(-width => 100, -height => 100); - -like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created"); - -# following a mail in zinc@tls.cena.fr (23 sept 2003) by A. Lemort -# we verify that the -width attribute of text items is converted as an integer -my $text = $zinc->add('text', 1, -position => [10,10], -text => "text"); - -&ok ($zinc->itemconfigure($text, -width => 10.1) or 1, "setting width to 10.1"); -&is ($zinc->itemcget($text, -width), 10, "width attribute was converted to an integer"); -&ok ($zinc->itemconfigure($text, -width => 9.9) or 1, "setting width to 10.9"); -&is ($zinc->itemcget($text, -width), 9, "width attribute was converted to lower integer"); - - - -diag("############## text items test"); diff --git a/Perl/t/Transformations.t b/Perl/t/Transformations.t deleted file mode 100644 index e736837..0000000 --- a/Perl/t/Transformations.t +++ /dev/null @@ -1,304 +0,0 @@ -#!/usr/bin/perl -w - -# -# $Id: Transformations.t,v 1.3 2004-04-02 12:03:34 mertz Exp $ -# Author: Christophe Mertz -# - -# testing all the import - -BEGIN { - if (!eval q{ -# use Test::More qw(no_plan); - use Test::More tests => 21; - 1; - }) { - print "# tests only work properly with installed Test::More module\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - use Tk::Zinc; - 1; - }) { - print "unable to load Tk::Zinc"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - MainWindow->new(); - 1; - }) { - print "# tests only work properly when it is possible to create a mainwindow in your env\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } -} - - -$mw = MainWindow->new(); -$zinc = $mw->Zinc(-width => 100, -height => 100); -my $coords = [ [10,10], [40, 40] ]; - -like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created"); - -my $g = $zinc->add('group',1); -$zinc->scale($g,2,2); -my $rect1 = $zinc->add('rectangle', $g, [10,10,40,40]); - -# todo : add a test for the to-come method to get a transform! - -is_deeply([ $zinc->coords($rect1) ], - [ [10,10], [40, 40] ], - "coords are not modified by the group transform!"); - -is_deeply([ - $zinc->transform(1, $g, [100, 100, 300, 500] ) - ], - [ 50, 50, 150, 250 ], - "transform from window coordinates to group"); - -is_deeply([ - $zinc->transform($g, 1, [$zinc->coords($rect1)] ) - ], - [ [20,20], [80, 80] ], - "transform to window coordinates"); - - -# question suggested by D. Etienne (30 sept 2003): -# is it possible to get the window coordinate of a transformed item? -# the answer is of course yes and it is verified here. -my $rect2 = $zinc->add('rectangle', 1, [10,10,40,40]); - -# applying a transform to the rectangle: -$zinc->scale($rect2, 2,2); - -# todo : add a test for the to-come method to get a transform! - -is_deeply([ $zinc->coords($rect1) ], - [ [10,10], [40, 40] ], - "coords are not modified by the item transform!"); - -is_deeply([ - $zinc->transform(1, $rect2, [100, 100, 300, 500] ) - ], - [ 50, 50, 150, 250 ], - "transform window coordinates with same transform than rect2 "); -is_deeply([ - $zinc->transform($rect2, 1, [$zinc->coords($rect2)] ) - ], - [ [20,20], [80, 80] ], - "transform rect2 coordinates to window coordinates, with group 1"); - -is_deeply([ - $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] ) - ], - [ [20,20], [80, 80] ], - "transform rect2 coordinates to window coordinates with 'device'"); - -$zinc->scale(1, 0.5, 0.5); - -is_deeply([ - $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] ) - ], - [ [10,10], [40, 40] ], - "transform rect2 coordinates to window coordinates with 'device'"); - -# setting the top group transformation to the id, with a translation with tset -$zinc->tset(1, 1,0, 0,1, -20,-10); -is_deeply([ - $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] ) - ], - [ [0,10], [60, 70] ], - "rect2 window coordinates with 'device' after topgroup transfo setting"); - -# restting top group transformation -$zinc->treset(1); -is_deeply([ - $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] ) - ], - [ [20,20], [80, 80] ], - "rect2 window coordinates with 'device' after topgroup treset"); - -# resetting the rect2 trasnformation -$zinc->treset($rect2); -is_deeply([ - $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] ) - ], - [ [10,10], [40, 40] ], - "rect2 window coordinates with 'device' after rect2 treset"); - -$zinc->treset($rect2); -$zinc->skew($rect2, 10,00); -$zinc->skew($rect2, -10,00); -ok(&similarPoints ([ - $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] ) - ], - [ [10, 10], [40, 40] ]), - "rect2 window coordinates with 'device' after rect2 skew (back and forth)"); - - -$zinc->treset($rect2); -$zinc->skew($rect2, -10,00); -$zinc->skew($rect2, 10,00); -ok(&similarPoints ([ - $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] ) - ], - [ [10, 10], [40, 40] ]), - "rect2 window coordinates with 'device' after rect2 skew (forth and back)"); - - -$zinc->treset($rect2); -$zinc->translate($rect2, 34,43); -$zinc->translate($rect2, 15,15, 'absolute'); # the previous relative translation will be overridden -is_deeply([ - $zinc->transform($rect2, 'device', [$zinc->coords($rect2)] ) - ], - [ [25,25], [55, 55] ], - "rect2 window coordinates with 'device' after rect2 absolute translation"); - -if (0) { -$zinc->treset($rect2); -print "0 ", $zinc->tget($rect2, 'rotation'), "\n"; -$zinc->rotate($rect2, 3.14159); -print "+3.14 ", $zinc->tget($rect2, 'rotation'), "\n"; -$zinc->rotate($rect2, -3.14159, 0); -print "0 ", $zinc->tget($rect2, 'rotation'), "\n"; -$zinc->rotate($rect2, 180, 1); -print "180 ", $zinc->tget($rect2, 'rotation'), "\n"; -$zinc->rotate($rect2, -3.14159, 100, 200); -print "0 ", $zinc->tget($rect2, 'rotation'), "\n"; -$zinc->rotate($rect2, -3.14159, 0, 100, 200); -print "3.14 ", $zinc->tget($rect2, 'rotation'), "\n"; -$zinc->rotate($rect2, 180, 1, 100, 200); -print "0 ", $zinc->tget($rect2, 'rotation'), "\n"; -$zinc->rotate($rect2, 180, 1, 100, 200, 300); -print "3.14 ", $zinc->tget($rect2, 'rotation'), "\n"; -$zinc->rotate($rect2, 180, 1, 100, 200, 300, 600); -print $zinc->tget($rect2, 'rotation'), "\n"; -$zinc->rotate($rect2, 180, 1, 100, 200, 300, 600, 900); -print $zinc->tget($rect2, 'rotation'), "\n"; -} - -$zinc->treset($rect2); -$zinc->translate($rect2, 40,50); -$zinc->scale($rect2, 2,3); -$zinc->rotate($rect2, 3.1415/2); - -my ($m00, $m01, $m10, $m11, $m20, $m21) = $zinc->tget($rect2); -#print "matrix: $m00, $m01, $m10, $m11, $m20, $m21\n"; -ok(&similarFlatArray ([$zinc->tget($rect2)], - [0, 2, -3, 0, -150, 80], - [0.001, 0.001, 0.001, 0.001, 1, 1]), - "tget of rect2"); - -my ($xTranslate, $yTranslate, $xScale, $yScale, $angle, $skew) = $zinc->tget($rect2, 'all'); -#print "matrix: $xTranslate, $yTranslate, $xScale, $yScale, $angle, $skew\n"; -ok(&similarFlatArray ([$zinc->tget($rect2,'all')], - [-150, 80, 2, 3, 3.14159/2, 0 ], - [1, 1, 0.001, 0.001, 0.001, 0.001]), - "tget 'all' of rect2"); - - -($xTranslate, $yTranslate) = $zinc->tget($rect2, 'translation'); -#print "translate: $xTranslate, $yTranslate\n"; -ok(&similarFlatArray ([$zinc->tget($rect2,'translation')], - [-150, 80], - [1, 1 ]), - "tget 'translation' of rect2"); - -($xScale, $yScale) = $zinc->tget($rect2, 'scale'); -#print "scale: $xScale, $yScale\n"; -ok(&similarFlatArray ([$zinc->tget($rect2,'scale')], - [2, 3, ], - [0.001, 0.001]), - "tget 'scale' of rect2"); - -($m00, $m01, $m10, $m11, $m20, $m21) = $zinc->tget($rect2, 'rotation'); -ok(&similarFlatArray ([$zinc->tget($rect2,'rotation')], - [3.14159/2], - [0.001 ]), - "tget 'rotation' of rect2"); - -#$zinc->skew($rect2, 10,0); -ok(&similarFlatArray ([$zinc->tget($rect2,'skew')], - [0], - [0.001 ]), - "tget 'skew' of rect2"); - - -sub similarPoints { - my ($ref1, $ref2)= @_; - diag ("waiting a reference for \$ref1" . ref ($ref1)), return 0 unless ref ($ref1) eq 'ARRAY'; - diag ("waiting a reference for \$ref2"), return 0 unless ref ($ref2) eq 'ARRAY'; - - my @array1 = @{$ref1}; - my @array2 = @{$ref2}; - - diag ("arrays for \$ref1 and \$ref2 are not of same length"), return 0 - unless scalar @array1 == @array2; - - for my $i (0.. $#array1) { - my $pt1 = $array1[$i]; - my $pt2 = $array2[$i]; - diag ("waiting a reference to a point in elt $i \$ref1"), return 0 - unless ref $pt1 eq 'ARRAY'; - my (@pt1) = @{$pt1}; - diag ("waiting a reference to a point (x,y) in elt $i \$ref1"), return 0 - unless scalar @pt1 == 2 and &numerical($pt1[0]) and &numerical($pt1[1]) ; - - diag ("waiting a reference to a point in elt $i \$ref1"), return 0 - unless ref $pt2 eq 'ARRAY'; - my (@pt2) = @{$pt2}; - diag ("waiting a reference to a point (x,y) in elt $i \$ref2"), return 0 - unless scalar @pt2 == 2 and &numerical($pt2[0]) and &numerical($pt2[1]) ; - - diag ("delta > 0.001 between x of pt$i"), return 0 if abs($pt1[0]-$pt2[0]) > 0.001; - diag ("delta > 0.001 between y of pt$i"), return 0 if abs($pt1[1]-$pt2[1]) > 0.001; - } - return 1; -} - -sub similarFlatArray { - my ($ref1, $ref2, $deltaref)= @_; - diag ("waiting a reference for \$ref1"), return 0 unless ref ($ref1) eq 'ARRAY'; - diag ("waiting a reference for \$ref2"), return 0 unless ref ($ref2) eq 'ARRAY'; - diag ("waiting a reference for \$deltaref"), return 0 unless ref ($deltaref) eq 'ARRAY'; - - my @array1 = @{$ref1}; - my @array2 = @{$ref2}; - my @deltaarray = @{$deltaref}; - diag ("arrays for \$ref1 and \$ref2 and \$deltaref are not of same length,".$#array1.",".$#array2.",".$#deltaarray), return 0 - unless ($#array1 == $#array2) and ($#array2 == $#deltaarray); - for my $i (0.. $#array1) { - my $a = $array1[$i]; - my $b = $array2[$i]; - my $delta = $deltaarray[$i]; - diag ("waiting a numeric value for elt $i of \$ref1"), return 0 - unless &numerical($a); - diag ("waiting a numeric value for elt $i of \$ref2"), return 0 - unless &numerical($b); - diag ("waiting a numeric value for elt $i of \$deltaref"), return 0 - unless &numerical($delta); - - diag ("delta > $delta between elt $i of \$ref1 ($a) and \$ref2 ($b)"), return 0 - if (abs($a-$b) > $delta) ; - } - return 1; -} - - -sub numerical { - my ($v) = @_; - return 0 unless defined $v; - ### this really works!! - return $v eq $v*1; - } - - -diag("############## transformations test"); - - diff --git a/Perl/t/find.t b/Perl/t/find.t deleted file mode 100644 index b30be97..0000000 --- a/Perl/t/find.t +++ /dev/null @@ -1,200 +0,0 @@ -#!/usr/bin/perl -w - -# -# $Id: find.t,v 1.4 2004-09-01 09:00:44 mertz Exp $ -# Author: Christophe Mertz -# - -# testing find methods - -# this script can be used with an optionnal argument, an integer giving -# the delay in seconds during which the graphic updates will be displayed -# this is usefull for visual inspection! - -BEGIN { - if (!eval q{ -# use Test::More qw(no_plan); - use Test::More tests => 22; - 1; - }) { - print "# tests only work properly with installed Test::More module\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - use Tk::Zinc; - 1; - }) { - print "unable to load Tk::Zinc"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - $mw = MainWindow->new(); - 1; - }) { - print "# tests only work properly when it is possible to create a mainwindow in your env\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } -} - - -$zinc = $mw->Zinc(-render => 0, - -width => 400, -height => 400)->pack; - -like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created"); - - -### creating rectangles: -$g1 = $zinc->add('group',1, -tags => "gr1"); -$text = $zinc->add('text', $g1, -position => [-100,-100]); -$g2 = $zinc->add('group',$g1, -tags => "gr2"); - -$rect11 = $zinc->add('rectangle', $g2, [ 10,10,40,40]); -$rect12 = $zinc->add('rectangle', $g2, [ 50,10,80,40]); -$rect13 = $zinc->add('rectangle', $g2, [ 90,10,120,40]); -$rect21 = $zinc->add('rectangle', $g2, [ 10,50,40,80]); -$rect22 = $zinc->add('rectangle', $g2, [ 50,50,80,80], -tags => 'middle'); -$rect23 = $zinc->add('rectangle', $g2, [ 90,50,120,80]); -$rect31 = $zinc->add('rectangle', $g2, [ 10,90,40,120]); -$rect32 = $zinc->add('rectangle', $g2, [ 50,90,80,120]); -$rect33 = $zinc->add('rectangle', $g2, [ 90,90,120,120]); -$zinc->update; - -my @list; - -@list = $zinc->find('overlapping', 20,20,110,110, $g2); -&ok (&eq_array (\@list , - [ $rect33, $rect32, $rect31, $rect23, $rect22, $rect21, $rect13, $rect12, $rect11, ]), - "find overlapping all rectangles"); - -@list = $zinc->find('enclosed', 20,20,110,110, $g2); -&ok (&eq_array (\@list , - [ $rect22 ]), - "find enclosed the middle rectangle"); - -@list = $zinc->find('enclosed', 0,0,110,110, $g2); -&ok (&eq_array (\@list , - [ $rect22 , $rect21, $rect12, $rect11 ]), - "find enclosed the 4 left up rectangles"); - -@list = $zinc->find('ancestor', $rect33); -&ok (&eq_array (\@list , - [ $g2 , $g1, 1 ]), - "find ancestor of one rectangle"); - -@list = $zinc->find('withtag', ".gr1."); -#print "@list\n"; -&ok (&eq_array (\@list , - [ $g2, $text, ]), - "find direct descendant of group tagged gr1"); - -@list = $zinc->find('withtag', ".gr1*"); -#print "@list\n"; -&is_deeply ( [ @list ] , - [ $g2, ($zinc->find('withtag', ".gr1.gr2*"), $text ) ], - "find all descendant of group tagged gr1"); - -&is_deeply ( [ ($zinc->find('withtag', ".gr1.gr2*")) ], - [ ($zinc->find('withtag', "*gr2*")) ], - "comparing full pathtag and reduced pathtag to a group"); - -&is_deeply ( [ ($zinc->find('withtag', ".gr1.gr2.middle")) ], - [ ($zinc->find('withtag', "*gr2.middle")) ], - "comparing full pathtag and reduced pathtag to a rectangle"); - -&is_deeply ( [ ($zinc->find('withtag', ".gr1.gr2.middle")) ], - [ ($zinc->find('withtag', "*middle")) ], - "comparing full pathtag and reduced pathtag to a rectangle"); - -&is_deeply ( [ ($zinc->find('withtag', ".gr1.gr2.middle")) ], - [ ($zinc->find('withtag', "middle")) ], - "comparing full pathtag and reduced pathtag to a rectangle"); - -&is_deeply ( [ ($zinc->find('withtype', "group")) ], - [ $g1, $g2 ], - "find with type 'group'"); - -&is_deeply ( [ ($zinc->find('withtype', "group", ".$g1.")) ], - [ $g2 ], - "find with type 'group' starting from g1"); - -&is_deeply ( [ ($zinc->find('withtype', "group", ".$g1.")) ], - [ ($zinc->find('withtype', "group", ".$g1*")) ], - "find with type 'group' starting from g1"); - -&is_deeply ( [ ($zinc->find('withtype', "rectangle")) ], - [ $rect33, $rect32, $rect31, $rect23, $rect22, $rect21, $rect13, $rect12, $rect11, ], - "find with type 'rectangle'"); -&is_deeply ( [ ($zinc->find('withtype', "rectangle", ".$g1*")) ], - [ ($zinc->find('withtype', "rectangle")) ], - "find with type 'rectangle' starting from .g1*"); - - -## testing overlapping find with atomic group (for testig the bug -## reported by D. Etienne the 11th June 04 -$zinc->itemconfigure($g2, -atomic => 1); -@list = $zinc->find('overlapping', 20,20,110,110); -print "overlapping17 (",join (',', @list),") \$g2=$g2\n"; -&ok (&eq_array (\@list , - [ $g2 ]), - "find overlapping when group becomes atomic, without specifying starting group"); - -@list = $zinc->find('overlapping', 20,20,110,110,1); -print "overlapping18 (",join (',', @list),") \$g2=$g2\n"; -&ok (&eq_array (\@list , - [ $g2 ]), - "find overlapping when group becomes atomic, starting from group 1"); - -@list = $zinc->find('overlapping', 20,20,110,110,1,1); -&ok (&eq_array (\@list , - [ $g2 ]), - "find overlapping when group becomes atomic, recursively, starting from group 1"); - - -## testing enclosing find with atomic group -@list = $zinc->find('enclosed', 0,0,200,200); -print "enclosing20 (",join (',', @list),") \$g2=$g2\n"; -&ok (&eq_array (\@list , - [ $g2 ]), - "find enclosed when group becomes atomic, without specifying starting group"); - -@list = $zinc->find('enclosed', 0,0,200,200, 1); -print "enclosing21 (",join (',', @list),") \$g2=$g2\n"; -&ok (&eq_array (\@list , - [ $g2 ]), - "find enclosed when group becomes atomic, starting from group 1"); - -@list = $zinc->find('enclosed', 0,2,200,200, 1,1); -print "enclosing22 (",join (',', @list),") \$g2=$g2\n"; -&ok (&eq_array (\@list , - [ $g2 ]), - "find enclosed when group becomes atomic, recursively, starting from group 1"); - -# Tk::MainLoop; - - - -sub wait { - $zinc->update; - ok (1, $_[0]); - - my $delay = $ARGV[0]; - if (defined $delay) { - $zinc->update; - if ($delay =~ /^\d+$/) { - sleep $delay; - } else { - sleep 1; - } - } - -} - - - -diag("############## Images test"); diff --git a/Perl/t/test-methods.pl b/Perl/t/test-methods.pl deleted file mode 100644 index 9becf7e..0000000 --- a/Perl/t/test-methods.pl +++ /dev/null @@ -1,689 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# This non-regression test has been developped by C. Mertz - -use Tk; -use Tk::Zinc; -use Getopt::Long; -use TestLog; - -use strict; - -use constant ERROR => '--an error--'; - - -# the following list be coherent with the treatments done in the TEST section. -my @testsList = ( - 1 => 'test_contour_and_coords (quick)', - 2 => 'test_forbidden_operations_on_root_group (quick)', - 3 => 'test_errors (quick)', - 4 => 'test_bboxes (quick)', - 5 => 'test_gradient_coding (quick)', - ); -my %testsHash; -{ my @tests = @testsList; - while (@tests) { - my $num = shift (@tests); - my $comment = shift (@tests); - $testsHash{ $num } = $comment; - } -} - -unshift (@INC, "/usr/lib/perl5/Tk"); # for getting Tk some images; - -# les variables positionnées en fonction des options de la ligne de commande -my $opt_log = 0; -my $opt_trace = ""; -my $opt_render = -1; -my $opt_type = 0; -my $outfile; -my $opt_tests = "all"; - -# on récupère les options -Getopt::Long::Configure('pass_through'); -my $optstatus = GetOptions('log=i' => \$opt_log, - 'out=s' => \$outfile, - 'trace=s' => \$opt_trace, - 'render:s' => \$opt_render, - 'type=s' => \$opt_type, - 'help' => \&usage, - 'tests:s' => \$opt_tests, - ); - -# on teste la validité de l'option -render! -if ($opt_render eq '') { - print "-render option have no value!\n"; - &usage; -} -$opt_render = 1 if $opt_render == -1; -unless ($opt_render==0 or $opt_render==1 or $opt_render==2) { - print "-render option value must be 0, 1 or 2!\n"; - &usage; -} - - -$outfile = "methods-$Tk::Zinc::VERSION.log" if (!defined $outfile); - -&openLog($outfile, $opt_log); - -sub usage { - my ($text) = @_; - print $text,"\n" if (defined $text); - print "test-methods [options]\n"; - print " A non-regression test suite for zinc.\n"; - print " Some exhaustive test of TkZinc methods. Of course everything is not tested yet\n"; - print " options are:\n"; - print " -help to print this short help\n"; - print " -log trace level, defaulted to 0; higher level trace more infos\n"; - print " -out filename the log filename. defaulted to methods-<-rendering>.log\n"; - print " NB: the previous log file is always renamed with a .prev suffix\n"; - print " -render 0|1|2 to select the render option of TkZinc (defaulted to 1)\n"; - print " -trace to better trace usage of an option\n"; - print " -type to limits tests to this item type.\n"; - print " -tests to get the list of available tests.\n"; - print " -tests i,j,k... to define the list of tests to pass.\n"; - exit; -} - -my $mw = MainWindow->new(); - -&log (0, "testing Zinc-perl Version=" . $Tk::Zinc::VERSION . " - ", $mw->zinc(), "\n"); - -## must be done after the LOG file is open -my @tests = &parseTestsOpt($opt_tests); -my %tests; -foreach my $t (@tests) {$tests{$t} = $t } - - -# The explanation displayed when running this demo -my $label=$mw->Label(-text => "This is a non-regression test, testing -some sets of methods!", - -justify => 'left')->pack(-padx => 10, -pady => 10); - - -# Creating the zinc widget -my $zinc = $mw->Zinc(-width => 500, -height => 500, - -font => "10x20", # usually fonts are sets in resources - # but for this example it is set in the code! - -borderwidth => 0, -relief => 'sunken', - -render => $opt_render, - )->pack; - -&setZincLog($zinc); - -sub test_gradient_coding { - &log (0, "#---- Start of test_gradient_coding ----\n"); - my $log_level = 2 ; - ### CM to be done! - - ### first testing legal gradient - foreach (0..2) { - my $i=0; - foreach my $g ("red", "bLue","#ff00ff","rgb:12/34/56","CIEXYZ:1.2/0.9/3.4", - "CIEuvY:0.5/.4/0.9", "CIExyY:.52/0.1/0.8", "CIELab:99.1/43./56.1", - "CIELuv:88/-1/-2.1", "TekHVC:345/1.2/100", - ) { - ## first simple color, with different X legal coding - &test_eval ($log_level, "gname", $g,"grad".$i); - $i++; - ## the same color with transparency - my $transparency = ($i * 4) % 101; - &test_eval ($log_level, "gname", "$g;$transparency","grad".$i); - $i++; - } - - ## different axial gradient without the gradient type at the beginning - foreach my $g ("red|blue", "red |blue", "red | blue", - "red|green|blue", "red |green|blue", "red |green |blue", "red | green|blue" - , "red |green| blue", "red |green | blue", "red | green | blue") { - ## first simple color, with different X legal coding - &test_eval ($log_level, "gname", $g,"grad".$i); - $i++; - } - ## different axial gradient with explicit gradient type at the beginning - ## and different angle value! - foreach my $angle qw(0 12 90 271 360) { - foreach my $g ("=axial $angle |red|blue", - "=axial $angle | red|blue", - "=axial $angle | red |blue", - "=axial $angle | red | blue", - "=axial $angle | red|green|blue", - "=axial $angle |red |green|blue", - "=axial $angle |red |green |blue", - "=axial $angle |red | green|blue", - "red |green| blue", - "red |green | blue", - "red | green | blue", - ) { - ## first simple color, with different X legal coding - &test_eval ($log_level, "gname", $g,"grad".$i); - $i++; - } - } - # and now deleting unused named gradient - foreach my $j (0..$i-1) { - &test_eval ($log_level, "gdelete", "grad".$j); - } - } - - ### and now testing illegal gradient - my $i=-1; - &test_no_eval ("X color name with blank inside", - $log_level, "gname", "navy blue","grad".$i++); - &test_no_eval ("bad gradient type", - $log_level, "gname", "=badtype 1 |red|blue","grad".$i++); - &test_no_eval ("axial gradient with excessive parameters", - $log_level, "gname", "=axial 67 1 |red|blue","grad".$i++); - &test_no_eval ("radial gradient with excessive parameters", - $log_level, "gname", "=radial 30 32 1 |red|blue","grad".$i++); - &test_no_eval ("path gradient with excessive parameters", - $log_level, "gname", "=path 30 32 1 |red|blue","grad".$i++); - ## testing bad types for gradient type - # to be done - foreach my $j (0..$i-1) { - &test_eval ($log_level, "gdelete", "grad".$j); - } - - &log (0, "#---- End of test_gradient_coding -----\n"); -} # end of test_gradient_coding - -## TkZinc bbox method doesn't return correct values for bbox. This test -# function tries to find out in which cases these bbox are wrong -sub test_bboxes { - &log (0, "#---- Start of test_bboxes ----\n"); - &creating_items; # to know exactly which items exists at the beginning of this test - - # Rectangles - &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400]), - [100,200,300,400], "a simple rectangle"); - &bbox_must_be($zinc->add('rectangle', 1, [300,400,100,200]), - [100,200,300,400], "a simple reversed rectangle"); - - # Rectangles with linewidth = 2, 3, 4 and 5 - &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400], -linewidth =>2), - [100,200,300,400], "a simple rectangle with linewidth of 2"); - &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400], -linewidth =>3), - [100,200,300,400], "a simple rectangle with linewidth of 3"); - &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400], -linewidth =>4), - [100,200,300,400], "a simple rectangle with linewidth of 4"); - &bbox_must_be($zinc->add('rectangle', 1, [100,200,300,400], -linewidth =>5), - [100,200,300,400], "a simple rectangle with linewidth of 5"); - - # Rectangular curves - &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ], - -linewidth =>0), - [100,200,300,400], "a rectangular curve of linewidth => 0"); - &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ]), - [100,200,300,400], "a rectangular curve of linewidth => 1"); - &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ], - -linewidth => 2), - [100,200,300,400], "a rectangular curve of linewidth => 2"); - &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ], - -linewidth => 3), - [100,200,300,400], "a rectangular curve of linewidth => 3"); - &bbox_must_be($zinc->add('curve', 1, [ [100,200], [300,200], [300,400], [100,400] ], - -linewidth => 5), - [100,200,300,400], "a rectangular curve"); - - # triangular curves (with a sharp angle) - &bbox_must_be($zinc->add('curve', 1, [ [0,0], [100,0], [0,10] ]), - [0,0,100,10], "a triangular curve of linewidth => 1)"); - - # Arcs - &bbox_must_be($zinc->add('arc', 1, [100,200,300,400]), - [100,200,300,400], "an arc"); - &bbox_must_be($zinc->add('arc', 1, [100,200,300,400], -linewidth => 2), - [100,200,300,400], "an arc of linewidth => 2"); - &bbox_must_be($zinc->add('arc', 1, [100,200,300,400], -linewidth => 3), - [100,200,300,400], "an arc of linewidth => 3"); - - - &log (0, "#---- End of test_bboxes -----\n"); -} # end of test_bboxes - -sub bbox_must_be { - my ($item, $bbox_ref, $explanation) = @_; - my @computed_bbox=$zinc->bbox($item); - my @theoritical_bbox = @{$bbox_ref}; - unless (&equal_flat_arrays (\@theoritical_bbox, \@computed_bbox)) { - &log(-10, "bad bbox of $explanation:\n ## computed = ", &printableArray(\@computed_bbox), - " theoritical = ", &printableArray(\@theoritical_bbox), "\n"); - } -} # end of bbox_must_be - - -sub test_contour_and_coords { - &log (0, "#---- Start of test_contour_and_coords ----\n"); - my $log_level = 2 ; - - $zinc->add('rectangle', 1, [ [100,200], [400,300] ], -tags => ['rect1']); - my $contour_rect = [ [100,200], [100,300], [400,300], [400,200] ]; - my $rev_contour_rect = [ [100,200], [400,200], [400,300], [100,300] ]; - - $zinc->add('rectangle', 1, [ 100,200, 400,300 ], -tags => ['rect2']); - &verify_coords_of_contour ('eq','rect1', 'rect2', 0); - &verify_coords_of_contour_points ('eq','rect1', 'rect2', 0); - - - $zinc->add('arc', 1, [ [100,200], [400,300] ], -tags => ['arc1']); - $zinc->add('arc', 1, [ 100,200, 400,300 ], -tags => ['arc2']); - &verify_coords_of_contour ('eq','arc1', 'arc2', 0); - &verify_coords_of_contour_points ('eq','arc1', 'arc2', 0); - - my $contour1 = [ [100,200], [400,300,'c'], [500,100], [350,10, 'c'], [300,500,'c'], [50,100] ]; - my $contour2 = [ 100,200, 400,300, 500,100, 350,10, 300,500, 50,100 ]; - my $contour3 = [ [100,200], [400,300], [500,100], [350,10], [300,500], [50,100]]; - $zinc->add('curve', 1, $contour1, -tags => ['curve1']); - $zinc->add('curve', 1, $contour2, -tags => ['curve2']); - $zinc->add('curve', 1, $contour3, -tags => ['curve3']); - &verify_coords_of_contour ('ne','curve1', 'curve2', 0); - &verify_coords_of_contour_points ('ne','curve1', 'curve2', 0); - - &verify_coords_of_contour ('eq','curve2', 'curve3', 0); - &verify_coords_of_contour_points ('ne','curve2', 'curve3', 0); - - ## testing contours - $zinc->add('curve', 1, [], -tags => ['curve_contour_0']); - $zinc->add('curve', 1, [], -tags => ['curve_contour_plus']); - $zinc->add('curve', 1, [], -tags => ['curve_contour_minus']); - $zinc->contour('curve_contour_0','add',0, $contour1); - $zinc->contour('curve_contour_plus','add',+1, $contour1); - $zinc->contour('curve_contour_minus','add',-1, $contour1); - &verify_coords_of_contour ('eq','curve1', 'curve_contour_0', 0); - &verify_coords_of_contour ('ne','curve_contour_plus', 'curve_contour_minus', 0); - if (&nequal_cplx_arrays ($zinc->coords('curve_contour_0',0), - $zinc->coords('curve_contour_minus',0))) { - &verify_coords_of_contour ('eq','curve1', 'curve_contour_plus', 0); - } else { - &verify_coords_of_contour ('eq','curve1', 'curve_contour_minus', 0); - } - $zinc->add('curve', 1, [], -tags => ['curve_contour_minus_plus']); - $zinc->contour('curve_contour_minus_plus','add',1, - [$zinc->coords('curve_contour_minus',0)]); - &verify_coords_of_contour ('eq','curve1', 'curve_contour_minus_plus', 0); - - ## the following curves are similar, because the first contour is - ## always set counterclockwise - $zinc->add('curve', 1, $contour_rect, -tags => ['curve_rect_coords']); - $zinc->add('curve', 1, $rev_contour_rect, -tags => ['curve_rect_coords_reversed']); - &verify_coords_of_contour ('ne','curve_rect_coords', 'curve_rect_coords_reversed', 0); # we should test they are reversed - - $zinc->add('curve', 1, [], -tags => ['curve_rect_0']); - $zinc->add('curve', 1, [], -tags => ['curve_rect_plus']); - $zinc->add('curve', 1, [], -tags => ['curve_rect_minus']); - - ## the following lines are errors: we cannot add an item as contour with flag 0 - &test_no_eval ("adding a contour from a rectangle with flag=0", - $log_level, "contour", 'curve_rect_0','add',0, 'rect1'); - &test_no_eval ("adding a contour from an arc with flag=0", - $log_level, "contour", 'curve_rect_0','add',0, 'arc1'); - - $zinc->contour('curve_rect_plus','add',1, 'rect1'); - $zinc->contour('curve_rect_minus','add',-1, 'rect1'); - &verify_coords_of_contour ('ne','curve_rect_plus', 'curve_rect_minus', 0); - &verify_coords_of_contour ('eq','curve_rect_coords', 'curve_rect_plus', 0); - &verify_coords_of_contour ('eq','curve_rect_coords_reversed', 'curve_rect_minus', 0); - - $zinc->add('tabular',1, 2, -tags => ['tabular1']); - $zinc->add('track',1, 2, -tags => ['track1']); - $zinc->add('waypoint',1, 2, -tags => ['waypoint1']); - $zinc->add('reticle',1, -tags => ['reticle1']); - - ## we test now the following errors: we cannot use a track, waypoint, reticle, map as a contour - &test_eval ($log_level, "contour", 'curve_rect_0','add',1, 'tabular1'); - &test_no_eval ("using the contour of a track", - $log_level, "contour", 'curve_rect_0','add',1, 'track1'); - &test_no_eval ("using the contour of a waypoint", - $log_level, "contour", 'curve_rect_0','add',1, 'waypoint1'); - &test_no_eval ("using the contour of a reticle", - $log_level, "contour", 'curve_rect_0','add',1, 'reticle1'); - - ## we test now the following errors: we cannot add a contour to track, waypoint, rectangle... - &test_no_eval ("adding a contour to a track", - $log_level, "contour", 'track1','add',1, 'rect1'); - &test_no_eval ("adding a contour to a waypoint", - $log_level, "contour", 'waypoint1','add',1, 'rect1'); - &test_no_eval ("adding a contour to a rectangle", - $log_level, "contour", 'rect1','add',1, 'rect2'); - - &test_no_eval ("adding a contour with a malformed list", - $log_level, "contour", 'curve_rect_0','add',1, [1]); - &test_no_eval ("adding a contour with a malformed list", - $log_level, "contour", 'curve_rect_0','add',1, [1, 2, 3]); - &test_no_eval ("adding a contour with a malformed list", - $log_level, "contour", 'curve_rect_0','add',1, [1, 2, 'c']); - &test_no_eval ("adding a contour with a malformed list", - $log_level, "contour", 'curve_rect_0','add',1, [1, 2, [3, 4] ]); - &test_no_eval ("adding a contour with a malformed list", - $log_level, "contour", 'curve_rect_0','add',1, [1, 2, [3, 4], [5, 6] ]); - - # we should test here what happens when successive points are identical in a curve - - # we should test here what happens when the last point is identical to the first point in a curve - - &log (0, "#---- End of test_contour_and_coords -----\n"); -} # end of test_contour_and_coords - - - -sub test_forbidden_operations_on_root_group { - &log (0, "#---- Start of test_forbidden_operations_on_root_group ----\n"); - my $log_level = 2 ; - - my @all_items = $zinc->find('withtag',".1*"); - print "Items before deleting 1: @all_items\n"; - &test_no_eval ("removing the root group", - $log_level, "remove", 1); ## cannot delete root group - @all_items = $zinc->find('withtag',".1*"); - print "Items after deleting 1: @all_items\n"; - $zinc->add('group', 1, -tags => "g2"); - # cannot chggroup root group: - &test_no_eval ("changing the group of the root group", - $log_level, "chggroup", 1,"g2"); - # cannot clone root group - &test_no_eval ("cloning the root group", - $log_level, "clone", 1); - - &log (0, "#---- End of test_forbidden_operations_on_root_group -----\n"); -} # end of test_forbidden_operations_on_root_group - - -### tests all errors as defined in the refman -sub test_errors { - &log (0, "#---- Start of test_errors ----\n"); - my $log_level = 2 ; - - &creating_items; - - ## add method with bad argument - # In a curve, it is an error to have more than two succcessive control points - # or to start or finish a curve with a control point. - &test_no_eval ("having more than two succcessive control points", - $log_level, "add", 'curve', 1, - [ [10,20], [30,40,'c'], [50,60,'c'], [70,80,'c'], [90,100] ]); - &test_no_eval ("starting a curve with a control point", - $log_level, "add", 'curve', 1, - [ [30,40,'c'], [50,60], [70,80], [90,100] ]); - &test_no_eval ("finishing a curve with a control point", - $log_level, "add", 'curve', 1, - [ [30,40,], [50,60,'c'], [70,80], [90,100,'c'] ]); - - # Text indices - # sel.first Refers to the first character of the selection in the item. - # If the selection is not in the item, this form returns an error. - &test_no_eval ("refering to sel.first in a text item without selection", - $log_level, "insert", 'text', 'sel.first', "string"); - # sel.last Refers to the last character of the selection in the item. - # If the selection is not in the item, this form returns an error. - &test_no_eval ("refering to sel.last in a text item without selection", - $log_level, "insert", 'text', 'sel.last', "string"); - - # If no item is named by tagOrId or if the item doesn t support anchors, - # an error is raised. - &test_no_eval ("refering no item by tagOrId with anchorxy", - $log_level, "anchorxy", 'bad_tag', 'rectangle'); - - # If the item doesn't support anchors, an error is raised. - &test_no_eval ("refering item that does not support anchors", - $log_level, "anchorxy", 'rectangle', 'ne'); - - # If the item doesn't support anchors, an error is raised. - &test_no_eval ("refering a bad anchor name", - $log_level, "anchorxy", 'text', 'not_an_anchor'); - -# If the command parameter is omitted, bind returns the command associated -# with tagOrId and sequence or an error is raised if there is no such binding. - &test_no_eval ("refering a non-existing bindind with bind", - $log_level, "bind", 'text', 'badseq'); - -# $zinc->contour(tagOrId, operatorAndFlag, coordListOrTagOrId); - # An error is generated if items are not of a correct type or if the - # coordinate list is malformed. - # tested in &test_contour_and_coords - -# If no items are named by tagOrId, an error is raised. - &test_no_eval ("refering a non-existing item with hasanchors", - $log_level, "hasanchors", 'badtag'); - -# If no items are named by tagOrId, an error is raised. - &test_no_eval ("refering a non-existing item with hasfields", - $log_level, "hasfields", 'badtag'); - - # If no items are named by tagOrId, an error is raised. - &test_no_eval ("refering a non-existing item with hastag", - $log_level, "hastag", 'badtag', 'atag'); - - # If field is given, it must be a valid field index for the item or - # an error will be reported. - &test_no_eval ("accessing a non existing track field", - $log_level, "itemcget", 'track', 111, -text); - - # If the attribute is not available for the field or item type, - # an error is reported. - &test_no_eval ("accessing a non existing curve attribute", - $log_level, "itemcget", 'curve', -bad_attribute); - &test_no_eval ("accessing a non existing attribute of a track field", - $log_level, "itemcget", 'track', 1, -bad_attribute); - - # If field is given, it must be a valid field index for the item or an - # error will be reported. - &test_no_eval ("modifying a non existing track field", - $log_level, "itemconfigure", 'track', 111, -text => "foo"); - # If an attribute does not belong to the item or field, an error is reported: - &test_no_eval ("modifying a non existing curve attribute", - $log_level, "itemconfigure", 'curve', -bad_attribute => "foo"); - &test_no_eval ("modifying a non existing attribute of a track field", - $log_level, "itemconfigure", 'track', 1, -bad_attribute => "foo"); - -# If tagOrId doesn t name an item, an error is raised. - &test_no_eval ("lowering a non-existing item with lower", - $log_level, "lower", 'badtag', 'track'); -# If belowThis doesn t name an item, an error is raised. - &test_no_eval ("lowering an existing below an non-existing item with lower", - $log_level, "lower", 'track', 'badtag'); - -# If no items are named by tagOrId, an error is raised. - &test_no_eval ("refering a non-existing item with numparts", - $log_level, "numparts", 'badtag'); - -# If tagOrId describes neither a named transform nor an item, an error is raised. - &test_no_eval ("refering a non-existing item with rotate", - $log_level, "rotate", 'badtag', 180); -# If tagOrId describes neither a named transform nor an item, an error is raised. - &test_no_eval ("refering a non-existing item with scale", - $log_level, "scale", 'badtag', 2,2); -# If tagOrId describes neither a named transform nor an item, an error is raised. - &test_no_eval ("refering a non-existing item with translate", - $log_level, "translate", 'badtag', 200,200); - - # If the given name is not found among the named transforms, an error is raised. - &test_no_eval ("refering a non-existing named transform item with tdelete", - $log_level, "tdelete", 'badNamedTransform'); - -# ->transform ?? - - # If tagOrId describes neither a named transform nor an item, an error is raised. - &test_no_eval ("refering a non-existing named transform or item with treset", - $log_level, "treset", 'badNamedTransform'); - - # If tagOrId doesn t describe any item or if the transform named tName - # doesn't exist, an error is raised. - &test_eval ($log_level, "tsave", "text", "namedTransfrom"); - &test_no_eval ("refering a non-existing item with trestore", - $log_level, "trestore", 'badTag', 'namedTransform'); - &test_no_eval ("refering a non-existing named transform with trestore", - $log_level, "trestore", 'track', 'badNamedTransform'); - - # If tagOrId doesn t describe any item, an error is raised. - &test_no_eval ("refering a non-existing item with tsave", - $log_level, "tsave", 'badTag', 'otherNamedTransform'); - - # If no items are named by tagOrId, an error is raised. - &test_no_eval ("refering a non-existing item with type", - $log_level, "type", 'badTag'); - - &log (0, "#---- End of test_errors -----\n"); -} # end of test_errors - -sub creating_items { - # first removing all remaining items - foreach my $tag qw(group track waypoint tabular text icon reticle map - rectangle arc curve triangles window) { - $zinc->remove($tag); - } - # and then creating items - $zinc->add('group', 1, -tags => ['group']); - $zinc->add('track', 1, 5, -position => [100,200], -tags => ['track']); - $zinc->add('waypoint', 1, 5, -position => [200,100], -tags => ['waypoint']); - $zinc->add('tabular', 1, 5, -position => [100,20], -tags => ['tabular']); - $zinc->add('text',1, -tags => ['text']); - $zinc->add('icon', 1, -tags => ['icon']); - $zinc->add('reticle', 1, -tags => ['reticle']); - $zinc->add('map', 1, -tags => ['map']); - $zinc->add('rectangle', 1, [400,400 , 450,220], -tags => ['rectangle']); - $zinc->add('arc', 1, [10,10 , 50,50], -tags => ['arc']); - $zinc->add('curve', 1, [30,0 , 150,10, 100,110, 10,100, 50,140], -tags => ['curve']); - $zinc->add('triangles', 1, [200,200 , 300,200 , 300,300, 200,300], - -colors => ["blue;50", "red;20", "green;80"], -tags => ['triangles']); - $zinc->add('window', 1, -tags => ['window']); - foreach my $tag qw(group track waypoint tabular text icon reticle map - rectangle arc curve triangles window) { -# my $contour = $zinc->contour($tag); -# print "$tag := $contour\n"; - } - -} # end creating_items - - -sub verify_coords_of_contour { - my ($predicat, $id1, $id2, $contour) = @_; - my @contour1 = $zinc->coords($id1,$contour); - my @contour2 = $zinc->coords($id2,$contour); -# print "contour1: ", &printableArray (@contour1), "\n"; -# print "contour2: ", &printableArray (@contour2), "\n"; - my $res = &nequal_cplx_arrays (\@contour1, \@contour2); -# print "res=$res\n"; - if ($predicat eq 'eq') { - if ($res) { - &log(-100, "coords of $id1($contour) and $id2($contour) are not equal:\n\t". - &printableArray(@contour1)."\n\t".&printableArray(@contour2)."\n"); - } else { - &log(1, " # coords of $id1($contour) and $id2($contour) are OK ($predicat)\n"); - } - } elsif ($predicat eq 'ne') { - if (!$res) { - &log(-10, "coords of $id1($contour) and $id2($contour) should not be equal\n"); - } else { - &log(1, " # coords of $id1($contour) and $id2($contour) are OK ($predicat)\n"); - } - } else { - &log(-100, "unknown predicat: $predicat\n"); - } -} # end of verify_coords_of_contour; - - -sub verify_coords_of_contour_points { - my ($predicat, $id1, $id2, $contour) = @_; - my @contour1 = $zinc->coords($id1,$contour); - - my $nequal=0; - for (my $i = 0; $i < $#contour1; $i++) { - my @coords1 = $zinc->coords($id1,0,$i); - my @coords2 = $zinc->coords($id2,0,$i); - my $res = &equal_flat_arrays ( \@coords1, \@coords2 ); - if ($predicat eq 'eq') { - if (!$res) { - &log(-100, "coords of $id1($contour,$i) and $id2($contour,$i) are not equal:\n\t$res"); - } - } elsif ($predicat eq 'ne') { - if (!$res) { - $nequal=$res; - last; - } - } else { - &log(-100, "unknown predicat: $predicat\n"); - } - } - if ($predicat eq 'neq' and !$nequal) { - &log(-100, "coords of $id1($contour,i) and $id2($contour,i) should not be all equal\n"); - } else { - &log(1, " # coords of $id1($contour,i) and $id2($contour,i) are OK ($predicat)\n"); - } -} # end of verify_coords_of_contour_points; - - -sub parseTestsOpt { - my ($opt) = @_; - my @tests; - if ($opt eq '') { - print "Availables tests are:\n"; - while (@testsList) { - my $i = shift @testsList; - my $comment = shift @testsList; - print "\t$i => $comment\n"; - } - exit; - } elsif ( $opt eq 'all' ) { ## default! - &log (0, " # all tests will be passed through\n"); - @tests = sort keys %testsHash; - } elsif ( $opt =~ /^\d+(,\d+)*$/ ) { - @tests = split (/,/ , $opt); - my $testnumb = (scalar @testsList) / 2; - foreach my $test (@tests) { - die "tests num must not exceed $testnumb" if $test > $testnumb; - } - &log(0, "Test to be done:\n"); - foreach my $test (@tests) { - &log(0, "\t # $test => " . $testsHash{$test} . "\n"); - } - } else { - print "bad -tests value. Must be a list of integer separated by ,\n"; - &usage; - } - return @tests; -} # end of parseTestsOpt - -# ---------- TEST ------------------ -# the following code must be coherent with the tests list described -# on the very beginning of this file (see @testsList definition) - -if ($tests{1}) { - &test_contour_and_coords (); -} - -if ($tests{2}) { - &test_forbidden_operations_on_root_group (); -} - -if ($tests{3}) { - &test_errors; -} - -if ($tests{4}) { - &test_bboxes; -} - -if ($tests{5}) { - &test_gradient_coding; -} - -### we should also test multicontour curves -if ($tests{5}) { -# &test_coords; -} - -# #### &test_fonts; ## and specially big fonts with render = 1; -# #### &test_path_tags; -# #### &test_illegal_tags; - -# #### &test_illegal_call -# for example: -# calling a methode for an non-existing item -# getting coords, contours, fields, etc... of non-existing index -# -# cloning, deleting topgroup -# - -&log (0, "#---- End of test_method ----\n"); - -#MainLoop(); diff --git a/Perl/t/test-no-crash.pl b/Perl/t/test-no-crash.pl deleted file mode 100644 index f1e22a6..0000000 --- a/Perl/t/test-no-crash.pl +++ /dev/null @@ -1,880 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# This non-regression / memory leak test has been developped by Christophe Mertz - -use Tk; -use Tk::Zinc; -use Getopt::Long; -use TestLog; - -use strict; - -use constant ERROR => '--an error--'; - - -# the following list be coherent with the treatments done in the TEST section. -my @testsList = ( - 1 => 'test_mapitems (quick)', - 2 => 'test_every_field_attributes (long)', - 3 => 'test_attributes (medium)', - 4 => 'test_cloning (quick)', - 5 => 'test_coords (quick)', - ); -my %testsHash; -{ my @tests = @testsList; - while (@tests) { - my $num = shift (@tests); - my $comment = shift (@tests); - $testsHash{ $num } = $comment; - } -} - -# les variables positionnées en fonction des options de la ligne de commande -my $opt_log = 0; -my $opt_trace = ""; -my $opt_render = -1; -my $opt_type = 0; -my $outfile; -my $opt_tests = "all"; -my $opt_memoryleak = 0; - -# on récupère les options -Getopt::Long::Configure('pass_through'); -my $optstatus = GetOptions('log=i' => \$opt_log, - 'out=s' => \$outfile, - 'trace=s' => \$opt_trace, - 'render:s' => \$opt_render, - 'type=s' => \$opt_type, - 'help' => \&usage, - 'memoryleak' => \$opt_memoryleak, - 'tests:s' => \$opt_tests, - ); - -# on teste la validité de l'option -render! -if ($opt_render eq '') { - print "-render option have no value!\n"; - &usage; -} -$opt_render = 1 if $opt_render == -1; -unless ($opt_render==0 or $opt_render==1 or $opt_render==2) { - print "-render option value must be 0, 1 or 2!\n"; - &usage; -} - - -$outfile = "no-crash-$Tk::Zinc::VERSION.log" if (!defined $outfile); - -## in case of memoryleak test, logs are not written in a file -## and logs are limited to high level logs on the standard output -## (only those with a loglevel <= -1000 will be written on stdout) -my $nolog_file = 0; -if ($opt_memoryleak) { - $opt_log = -1000; - my $nolog_file = 1; -} - - - - -&openLog($outfile, $opt_log, $nolog_file); - -sub usage { - my ($text) = @_; - print $text,"\n" if (defined $text); - print "test-no-crash [options]\n"; - print " A non-regression test suite for zinc.\n"; - print " Some exhaustive test of zinc. Of course everything is not tested yet\n"; - print " options are:\n"; - print " -help to print this short help\n"; - print " -log trace level, defaulted to 0; higher level trace more infos\n"; - print " -out filename the log filename. defaulted to no-crash.log\n"; - print " NB: the previous log file is always renamed with a .prev suffix\n"; - print " -memoryleak to try to detect some memoryleak between first iteration of the test \n"; - print " and the following iteration. This test NEVER finish automatically\n"; - print " it is up to the tester to stop the memoryleak test after\n"; - print " a significative number of iterations\n"; - print " -render 0|1|2 to select the render option of zinc (defaulted to 1)\n"; - print " -trace to better trace usage of an option\n"; - print " -type to limits tests to this item type.\n"; - print " -tests to get the list of available tests.\n"; - print " -tests i,j,k... to define the list of tests to pass.\n"; - exit; -} - -my $mw = MainWindow->new(); - -&log (-1000, "#testing Zinc-perl Version=" . $Tk::Zinc::VERSION . " - ", $mw->zinc(), "\n"); - -## must be done after the LOG file is open: - -my @tests = &parseTestsOpt($opt_tests); -my %tests; -foreach my $t (@tests) {$tests{$t} = $t } - - -# The explanation displayed when running this demo -my $label=$mw->Label(-text => "This is a non-regression test, testing that -zinc is not core-dumping! It can also be used for detecting memory leaks", - -justify => 'left')->pack(-padx => 10, -pady => 10); - - -# Creating the zinc widget -my $zinc = $mw->Zinc(-width => 500, -height => 500, - -trackmanagedhistorysize => 10, - -font => "10x20", # usually fonts are sets in resources - # but for this example it is set in the code! - -borderwidth => 0, -relief => 'sunken', - -render => $opt_render, - )->pack; - -&setZincLog($zinc); - - -my %itemtypes; -my @itemtypes = qw(arc tabular track waypoint - curve rectangle triangles - group icon map reticle text window - ); - -if ($opt_type) { @itemtypes = ($opt_type); } - -foreach my $type (@itemtypes) { $itemtypes{$type}=1 } - -#### some global variables needed as attributes values -my ($text1, $text2, $text3, $text4); -my ($image1, $image2, $image3, $image4); - -&creating_items ("unused"); -&verifying_item_completion; - -sub creating_items { - # first removing all remaining items - foreach my $item (&test_eval (1, 'find', 'withtag', 'all')) { - &test_eval (1, "remove", $item); - } - - - my $labelformat = "x82x60+0+0 x60a0^0^0 x32a0^0>1 a0a0>2>1 x32a0>3>1"; - # and then creating items - &test_eval (1, "add", 'group', 1); - &test_eval (1, "add", 'group', 1); - &test_eval (1, "add", 'icon', 1); - &test_eval (1, "add", 'map', 1); - &test_eval (1, "add", 'map', 1); - &test_eval (1, "add", 'reticle', 1); - $text1 = &test_eval (1, "add", 'text', 1, -position => [300,120], -text => "hello world1"); - $text2 = &test_eval (1, "add", 'text', 1, -position => [350,170], -text => "hello world2"); - $text3 = &test_eval (1, "add", 'text', 1, -position => [400,220], -text => "hello world3"); - &test_eval (1, "add", 'window', 1); -# &test_eval (1, "add", 'track', 1, 5, -position => [100,200]); - &test_eval (1, "add", 'track', 1, 5, -position => [100,200], -labelformat => $labelformat); - &test_eval (1, "add", 'waypoint', 1, 5, -position => [200,100], -labelformat => $labelformat); - &test_eval (1, "add", 'tabular', 1, 5, -position => [100,20], -labelformat => $labelformat); - &test_eval (1, "add", 'group', 1); - - &test_eval (1, "mapinfo", 'mapinfo1', 'create'); - &test_eval (1, "mapinfo", 'mapinfo2', 'create'); - &test_eval (1, "mapinfo", 'mapinfo3', 'create'); - -#$zinc->itemconfigure ('tabular', -labelformat => "200x10"); -#$zinc->update; - - - - &test_eval (1, "add", 'arc', 1, [10,10 , 50,50]); - &test_eval (1, "add", 'curve', 1, [30,0 , 150,10, 100,110, 10,100, 50,140]); - &test_eval (1, "add", 'rectangle', 1, [400,400 , 450,220]); - &test_eval (1, "add", 'triangles', 1, [200,200 , 300,200 , 300,300, 200,300], - -colors => ["blue;50", "red;20", "green;80"]); - - # images are initialised ONLY ONCE! (to avoid memoryleaks) - $image1 = $zinc->Photo(-file => Tk::findINC("Tk/icon.gif") ) unless $image1; - $image2 = $zinc->Photo(-file => Tk::findINC("Tk/Xcamel.gif") ) unless $image2; - $image3 = $zinc->Photo(-file => Tk::findINC("Tk/tranicon.gif") ) unless $image3; - $image4 = $zinc->Photo(-file => Tk::findINC("Tk/anim.gif") ) unless $image4; - - &creating_datas; # some of the data are using items! -} # end creating_items - -# verifies that we create an item of every existing type -sub verifying_item_completion { - my @all_types = $zinc->add(); ## this use of add is not documented yet XXX! - my @all_items = $zinc->find ('withtag', 'all'); - my %created_item_types; - foreach my $item (@all_items) { - $created_item_types{$zinc->type($item)} = 1; - } - foreach my $type (@all_types) { - if (defined $created_item_types{$type}) { - delete $created_item_types{$type}; - } - else { - &log(-100, "item type \"type\" which exist in Zinc is not tested!\n"); - } - } - foreach my $type (sort keys %created_item_types) { - &log(-100, "This tested item type \"$type\" is supposed not to exist in Zinc!\n"); - } -} - - -my %options; -my %types; - - -foreach my $itemType (@itemtypes) { - my ($anItem) = $zinc->find('withtype', $itemType); - if (!defined $anItem) { &log (-10, "no item $itemType\n"); next;}; - my @options = $zinc->itemconfigure($anItem); - foreach my $elem (@options) { - my ($optionName, $optionType, $readOnly, $empty, $optionValue) = @$elem; - $options{$itemType}{$optionName} = [$optionType, $readOnly, $empty, $optionValue]; - $types{$optionType} = 1; - } -} - -my %fieldOptions; - -{ -my ($aTrack) = $zinc->find('withtype', 'track'); -if (!defined $aTrack) { &log (-10, "no item track\n") } -else { - my @fieldOptions = $zinc->itemconfigure($aTrack, 0); - for my $elem (@fieldOptions) { - my ($optionName, $optionType, $readOnly, $empty, $optionValue) = @$elem; - $fieldOptions{$optionName} = [$optionType, $readOnly, $empty, $optionValue]; - $types{$optionType} = 1; - } -} -} - -foreach my $type (sort keys %types) { -# print "$type\n"; -} - -# a hash giving samples of valid data for attributes types -my %typesValues; - -# the following hash associated to types valid value that should be all different from -# default value and from value initiated when creating items (see up...) -my %typesNonStandardValues; - -# a hash giving samples of NOT valid data for attributes types -my %typesIllegalValues; - -sub creating_datas { - return if defined $typesValues{'alignment'}; - %typesValues = - ('alignment' => ['left', 'right', 'center'], - 'alpha' => [0, 50, 100, 23], - 'anchor' => ['n', 's', 'e', 'w', 'nw', 'ne', 'sw', 'se', 'center'], - 'angle' => [0, 90, 180, 270, 360, 12, 93, 178, 272, 359], - 'autoalignment' => ['lll', 'llr', 'llc', 'lrl', 'lrr', 'lrc', 'lcl', 'lcr', 'lcc', - 'rll', 'rlr', 'rlc', 'rrl', 'rrr', 'rrc', 'rcl', 'rcr', 'rcc', - 'cll', 'clr', 'clc', 'crl', 'crr', 'crc', 'ccl', 'ccr', 'ccc', - '-',], - 'boolean' => [0..1], - 'bitmap' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], ####?! - 'bitmaplist' => [['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], ['AlphaStipple0']], ##TBC - 'capstyle' => ['butt', 'projecting', 'round'], - 'gradient' => ['green', 'LemonChiffon', '#c84', '#4488cc', '#888ccc444', 'red'], ## TBC - 'gradientlist' => [['green'], ['LemonChiffon'], ['#c84'], ['#4488cc'], ['#888ccc444'], - ['red', 'green'], ['red', 'green', 'blue'], - ['red;50', 'green;50', 'blue;50'], - ['blue;0', 'green;50', 'red;90'], - ], ## TBC - 'dimension' => [0..5, 10, 50, 100, 0.0, 5.5, 100.5, 4.5], ## and floats ?! - 'edgelist' => ['left', 'right', 'top', 'bottom', 'contour', 'oblique', 'counteroblique'], ## +combinations! - 'filerule', => ['odd', 'negative','positive', 'abs_ge_eq2'], - 'font' => ['10x20', '6x10', '6x12', '6x13'], - 'image' => [$image1, $image2, $image3], ## TBC - 'integer' => [-10000, -100, -1, 0, 1, 10, 10000], ## pour quoi? - 'item' => [$text1, $text2], - 'joinstyle' => ['bevel', 'miter', 'round'], - 'labelformat' => ["200x10", ## BUG BUG -# "200x100 x100x20+0+0 x100x20+0+20 x200x40+100+20" - ], - 'leaderanchors' => ["%10x30", "|0|0", "%40x20", "|1|1", "|100|100", "%67x21" ], ## TBC! non exchaustif!! BUG non conforme à la doc - # illegal et fait planter: "%50" - 'lineend' => [ [10,10,10], [10,100,10], [100,10,10], [10,10,100], [100,10,100] ], - 'lineshape' => ['straight', 'rightlightning', 'leftlightning', 'rightcorner', 'leftcorner', 'doublerightcorner', 'doubleleftcorner'], - 'linestyle' => ['dotted', 'simple', 'dashed', 'mixed', 'dotted'], - 'mapinfo' => ['mapinfo1','mapinfo2','mapinfo3'], ## TBC -# 'number' => [2.3, 1.0, 5.6, 2.1], - 'point' => [ [0,0] , [10,10], [20,20], [30,30], [20,20], [0,0] , [10,10] ], - 'priority' => [ 1, 10, 50, 1000, 10000 ], # positif ou nul - 'relief' => ['flat', 'groove', 'raised', 'ridge', 'sunken', - 'roundraised', 'roundsunken', 'roundgroove', - 'roundridge', 'sunkenrule', 'raisedrule'], - 'string' => ['teststring', 'short', 'veryverylongstring'], - 'taglist' => [ [1], [1..2], ['a','b'], ['tag1','tag2','tag3']], - 'unsignedint' => [ 0..5 , 10, 20, 30, 100 ], - 'window' => [], ## TBC - ); - -# the following valid value associated to types should be all different from -# default value and from value initiated when creating items (see up...) - %typesNonStandardValues = - ('alignment' => 'right', - 'alpha' => 50, - 'anchor' => 'w', - 'angle' => 45, - 'autoalignment' => 'llc', - 'bitmap' => 'AlphaStipple14', - 'bitmaplist' => ['AlphaStipple0', 'AlphaStipple3', 'AlphaStipple14', 'AlphaStipple11', 'AlphaStipple7'], - 'capstyle' => 'butt', - 'gradient' => 'LemonChiffon', - 'gradientlist' => ['red;50', 'green;50', 'blue;50'], - 'dimension' => 45, - 'edgelist' => 'contour', - 'font' => '6x10', - 'fillrule' => 'nonzero', - 'image' => $image4, - 'integer' => 7, - 'item' => $text3, - 'joinstyle' => 'miter', - 'labelformat' => "200x30", ## BUG BUG - 'leaderanchors' => "%10x45", ## BUG BUG - 'lineend' => [13,7,20], - 'lineshape' => 'rightlightning', - 'linestyle' => 'dotted', - 'mapinfo' => 'mapinfo2', ## TBC - 'number' => 7.6, - 'point' => [100,100], - 'priority' => 50, - 'relief' => 'groove', - 'string' => 'notsoshort', - 'taglist' => ['tag1','tag11','tag111'], - 'unsignedint' => 7, # 22, # 22 is to high for -visiblehistorysize and 5 is, the default value for reticle -period - 'window' => undef, ### TBC - ); - - %typesIllegalValues = - ('alpha' => [0..100], - 'anchor' => ['n', 's', 'e', 'w'], ##TBC - 'angle' => [0..360], - 'boolean' => [0..1], - 'capstyle' => [], - 'dimension' => [0..100], - 'font' => ['10x20', '6x10', '6x12', '6x13'], - 'leaderanchors' => ["%50" ], ## TBC! non exchaustif!! BUG non - 'relief' => ['flat', 'groove', 'raised', 'ridge', 'sunken', - 'roundraised', 'roundsunken', 'roundgroove', - 'roundridge', 'sunkenrule', 'raisedrule'], - ); -} - -$mw->Button(-text => "Exit", - -command => sub { exit }, - )->pack(-pady => 4); - -sub test_attributes { - &log (-1000, "#---- Start of test_attributes ----\n"); - foreach my $type (@itemtypes) { - my @items = $zinc->find('withtype', $type); - &log (0, "#--------- Testing ", (1+$#items), " ",$type," attributes ----------------\n"); - if ($#items == -1) { - &log (-100, "No such item: $type\n"); - next; - } - &log(0,"no such type '$type'\n"), next unless defined $options{$type}; -# print $options{$type}, "\t\t", %{$options{$type}}, "\n"; - my %theoptions = %{$options{$type}}; - foreach my $item (@items) { - ## il faudrait tester les options selon un ordre défini à l'avance - ## en passant par plusieurs occurences pour les options et en forçant - ## certaines valeurs, par exemple les valeurs booléennees... (visible/sensible/filled) - my @boolean_attributes; - my %boolean_attributes; - foreach my $option (sort keys %theoptions) { - my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; - if ($optionType eq 'boolean') { - next if $option eq -composerotation; - next if $option eq -composescale; - next if $option =~ /-\w+sensitive/ ; # to get rid of many track options! - next if $option =~ /-filled\w+/ ; # to get rid of many track options! - next if $option =~ /-speed\w+/ ; # to get rid of many track options! - next if $option =~ /-\w+history/ ; # to get rid of many track options! - push @boolean_attributes, $option; - $boolean_attributes{$option}=1; - } - } - &log (0, "# $type (id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n")); - foreach my $i (0 .. (2**(1+$#boolean_attributes) -1) ) { - my $format = "%0" . ($#{boolean_attributes} +1) . "b"; - my $binary = sprintf ($format,$i); - &log (0, "# $i/", (2**(1+$#boolean_attributes)), " $binary\n"); - my @binary = split (//,$binary); - foreach my $j (0 .. $#boolean_attributes) { - &test_eval (0, "itemconfigure", $item, $boolean_attributes[$j] => $binary[$j] ); -# &log (0, "setting $type ($item) ", $boolean_attributes[$j], " to ", $binary[$j], "\n"); - } - foreach my $option (sort keys %theoptions) { - next if ($option eq -numfields); # BUG? makes the appli stop - next if ($option eq "-clip" and $type = "group"); # BUG? This test cannot be random clipping item must belong to the group - next if ($boolean_attributes{$option}); # skipping boolean attributes which are exhaustively tested - - my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; - my $typeValues = $typesValues{$optionType}; - if (!defined $typeValues) {&log (-100, "No values for type $optionType (option $option)\n");next;} - my @values = @{$typeValues}; - - if (!@values) {&log (-100, "No values for type $optionType (option $option)\n");next;} - - - my $valueRef = ref ($values[0]); - my $previous_val; - my @previous_val; - - if ($valueRef eq '') { - $previous_val = $zinc->itemcget($item, $option); - } - else { - @previous_val = $zinc->itemcget($item, $option); - } - &log (1, "#** itemconfigure of $item ($type), $option => ",&printableList (@values),"\n"); - my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType ) ? 0 : 2 ; - foreach my $value (@values) { - &test_eval ($log_lev, "itemconfigure", $item, $option => $value); - $zinc->update; - $zinc->after(10); - } - - if ($valueRef eq '') { - &test_eval ($log_lev, "itemconfigure", $item, $option => $previous_val); - } - else { - &test_eval ($log_lev, "itemconfigure", $item, $option => \@previous_val); - } - - } - } - } - } - &log (0, "#---- End of test_attributes ----\n"); -} # end test_attributes - - -# test2: configurer les fields des track / waypoint / tabular -# jouer avec les labelformats - -# test3: tester toutes les fonctions aléatoirement selon les signatures - - -# test4: tester qu'en clonant on obtient bien une copie de tous les attributs - -sub test_cloning { - &log (-1000, "#---- Start of test_cloning ----\n"); - &creating_items; - foreach my $type (@itemtypes) { - my ($item) = $zinc->find('withtype', $type); - &log (0, "#--------- Cloning and testing item ",$type," $item ----------------\n"); - if (!defined $item) { &log (-10, "No such item: $type\n"); next;}; - my $clone = &test_eval(1, "clone", $item); - - &log (0, "#---- Modifying the clone $clone\n"); - &test_a_clone ($type, $item, $clone); - &test_enclosed_overlapping_closest($type, 'original', $item, $zinc->bbox ($item)); - &test_enclosed_overlapping_closest($type, 'clone', $clone, $zinc->bbox ($clone)); - &log (0, "#---- Modifying the original\n"); - &test_a_clone ($type, $clone, $item); - &test_enclosed_overlapping_closest($type, 'original', $item, $zinc->bbox ($item)); - &test_enclosed_overlapping_closest($type, 'clone', $clone, $zinc->bbox ($clone)); - &log (0, "#---- Deleting the original\n"); - &test_eval (1, "remove", $item); - &test_every_attributes_once($type,$clone); - &log (0, "#---- Deleting the clone\n"); - &test_eval (1, "remove", $clone); - } - # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox - # tester le closest avec le centre de la bbox - - # faire la même chose que juste avant, mais en interchangeant clone et original - # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox - # tester le closest avec le centre de la bbox - - # supprimer l'item original - - # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox - # tester le closest avec le centre de la bbox - - # modifier tous les attributs du clone - # supprimer le clone - - # tester le find enclosed / overlapping avec un rectangle un peu plus grand que la bbox - # tester le closest avec le centre de la bbox - - &log (0, "#---- End of test_cloning ----\n"); -} # end test_cloning - -## teste le find enclosed / overlapping avec un rectangle un peu plus grand -# que la bbox donnée en paramètre. -# si $item est différent de '', vérifie que l'item est enclosed/overlapping -## Vérifie aussi le fonctionnement ud closest pour le centre de la bbox -sub test_enclosed_overlapping_closest { - my ($type, $clone_or_original, $item, @bbox) = @_; - if ($#bbox == -1) { - &log(-100, "Undef bbox of a $type ($clone_or_original)\n"); - } - else { - @bbox = ( $bbox[0]-10, $bbox[1]-10, $bbox[2]+10, $bbox[3]+10 ); - my @items = &test_eval (1, "find", 'enclosed', @bbox); - goto TESTOVERLAPPING if ($item eq ''); - foreach my $i (@items) { - goto TESTOVERLAPPING if ($i eq $item); # the item is included! - } - &log(-100, "The $type ($clone_or_original) is not enclosed in its bbox!\n"); - TESTOVERLAPPING: -# @items = $zinc->find ('overlapping', @bbox); - @items = &test_eval (1, "find", 'overlapping', @bbox); - goto TESTCLOSEST if ($item eq ''); - foreach my $i (@items) { - goto TESTCLOSEST if ($i eq $item); - } - &log(-100, "The $type ($clone_or_original) is not overlapping its bbox!\n"); - TESTCLOSEST: - my $x = ($bbox[0] + $bbox[2] )/2; - my $y = ($bbox[1] + $bbox[3] )/2; -# my $closest = $zinc->find ('closest', $x,$y); - my $closest = &test_eval (1, "find", 'closest', $x,$y); - } -} # end test_enclosed_overlapping_closest - -sub test_a_clone { - my ($type, $original, $clone) = @_; - my %theoptions = %{$options{$type}}; - foreach my $option (sort keys %theoptions) { - next if ($option eq -numfields); # BUG? makes the appli stop - next if ($option eq "-clip" and $type = "group"); # BUG? This test cannot be random. Clipping item must belong to the group - next if ($option eq '-connecteditem'); ## XXX this test should be corrected implemented, - my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; - my $value = $typesNonStandardValues{$optionType}; - if ($optionType ne 'boolean' && !defined $value) { - &log (-100, "No value for type $optionType (option $option)\n"); - next; - } - - my $valueRef = ref ($value); - my $previous_val; - my @previous_val; - - # memoryzing previous value of the clone - if ($valueRef eq '') { - $previous_val = &test_eval (2, "itemcget", $clone, $option); - } - else { - @previous_val = &test_eval (2, "itemcget", $clone, $option); - } - - # in the case of boolean, we must always take the not value: - if ($optionType eq 'boolean') { $value = !$previous_val } - - my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ; - &test_eval ($log_lev, "itemconfigure", $clone, $option => $value); - $zinc->update; - - if ($valueRef eq 'ARRAY') { # the value is a list - my @original_value = &test_eval (2, "itemcget", $original, $option); - my @clone_value = &test_eval (1, "itemcget", $clone, $option); - if ( &equal_flat_arrays (\@original_value, \@clone_value) ) { - &log (-100, "Modified cloned $type gets the same value for $option (type $optionType) ". &printableArray(@original_value) . "\n"); - } - } - else { # the value is either a scalar or a class instance - my $original_value = &test_eval (2, "itemcget", $original, $option); - my $clone_value = &test_eval (2, "itemcget", $clone, $option); - if (defined $original_value && $original_value eq $clone_value) { -# print "ORIGIN = ",$original_value, " $original_value CLONE = ",$clone_value,"\n"; - &log (-100, "Modified cloned $type gets the same value for $option (type $optionType) " . - "(original=cloned: " . &printableItem($original_value) . - "?=" . &printableItem($previous_val) . - " :previous)\n"); - } - } - - # setting back the previous value - if ($valueRef eq '') { - &test_eval (1, "itemconfigure", $clone, $option => $previous_val); - } - else { - &test_eval (1, "itemconfigure", $clone, $option => \@previous_val); - } - - } -} # end test_a_clone - -sub test_every_attributes_once { - my ($type, $item) = @_; - my %theoptions = %{$options{$type}}; - foreach my $option (sort keys %theoptions) { - next if ($option eq -numfields); # BUG? makes the appli stop - next if ($option eq "-clip" and $type = "group"); # BUG? This test cannot be random. Clipping item must belong to the group - next if ($option eq '-connecteditem'); ## XXX this test should be corrected implemented, - my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; - my $value = $typesNonStandardValues{$optionType}; - if ($optionType ne 'boolean' && !defined $value) { - &log (-100, "No value for type $optionType (option $option)\n"); - next; - } - # in the case of boolean, we must always take the not value: - if ($optionType eq 'boolean') { $value = !$zinc->itemcget($item, $option) } - - my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ; - &test_eval ($log_lev, "itemconfigure", $item, $option => $value); - $zinc->update; - } -} # end test_every_attributes_once - - -sub test_every_field_attributes { - &log (-1000, "#---- Start of test_every_field_attributes ----\n"); - foreach my $type qw(waypoint track tabular) { - next unless $itemtypes{$type}; - my %theoptions = %fieldOptions; - my @items = $zinc->find('withtype', $type); - &log (0, "#--------- Testing field attributes of ", (1+$#items), " ",$type,"(s) ----------------\n"); - if ($#items == -1) { - &log (-100, "No such item: $type\n"); - next; - } - foreach my $item (@items) { - ## il faudrait tester les options selon un ordre défini à l'avance - ## en passant par plusieurs occurences pour les options et en forçant - ## certaines valeurs, par exemple les valeurs booléennees... (visible/sensible/filled) - my @boolean_attributes; - my %boolean_attributes; - foreach my $option (sort keys %theoptions) { - my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; - if ($optionType eq 'boolean') { -# next if $option =~ /-\w+sensitive/ ; # to get rid of many track options! -# next if $option =~ /-filled\w+/ ; # to get rid of many track options! -# next if $option =~ /-speed\w+/ ; # to get rid of many track options! -# next if $option =~ /-\w+history/ ; # to get rid of many track options! - push @boolean_attributes, $option; - $boolean_attributes{$option}=1; - } - } - &log (0, "# $type (id $item) : ", ((2**(1+$#boolean_attributes)) , " Combinations (", join (', ' , @boolean_attributes),")\n")); - foreach my $i (0 .. (2**(1+$#boolean_attributes) -1) ) { - my $format = "%0" . ($#{boolean_attributes} +1) . "b"; - my $binary = sprintf ($format,$i); - &log (0, "# $i/", (2**(1+$#boolean_attributes)), " $binary\n"); - my @binary = split (//,$binary); - foreach my $j (0 .. $#boolean_attributes) { - &log (0, "# setting $type ($item) field 0..",$zinc->itemcget($item, -numfields)-1, " ", $boolean_attributes[$j], " to ", $binary[$j], "\n"); - foreach my $field (0 .. $zinc->itemcget($item, -numfields)-1 ) { - &test_eval (1, "itemconfigure", $item, $field, $boolean_attributes[$j] => $binary[$j] ); - } - } - foreach my $field (0 .. $zinc->itemcget($item, -numfields)-1 ) { - foreach my $option (sort keys %theoptions) { - next if ($boolean_attributes{$option}); # skipping boolean attributes which are exhaustively tested - - my ($optionType, $readOnly, $empty, $optionValue) = @{$theoptions{$option}}; - - my $typeValues = $typesValues{$optionType}; - if (!defined $typeValues) {&log (-100, "No values for type $optionType (option $option)\n");next;} - my @values = @{$typeValues}; - - if (!@values) {&log (-100, "No values for type $optionType (option $option)\n");next;} - - - my $valueRef = ref ($values[0]); - my $previous_val; - my @previous_val; - - if ($valueRef eq '') { - $previous_val = &test_eval (1, "itemcget", $item, $field, $option); - } - else { - @previous_val = &test_eval (1, "itemcget", $item, $field, $option); - } - &log (1, "#** itemconfigure ($item ($type), $field, $option => ",&printableList (@values),"\n"); - foreach my $value (@values) { - my $log_lev = ($opt_trace eq $option || $opt_trace eq $optionType) ? 0 : 2 ; - &test_eval ($log_lev, "itemconfigure", $item, $field, $option => $value); - $zinc->update; - $zinc->after(10); - } - - if ($valueRef ne 'ARRAY') { - &test_eval (1, "itemconfigure", $item, $field, $option => $previous_val); - } - else { - &test_eval (1, "itemconfigure", $item, $field, $option => \@previous_val); - } - - }} - } - } - } - &log (0, "#---- End of test_every_field_attributes ----\n"); -} # end test_every_field_attributes - - -sub createMapInfo { - my ($name, $N,$deltaN, $radius, $centerX,$centerY) = @_; - &test_eval (1, "mapinfo", $name, 'create'); - - my @lineTypes=(qw/simple dashed dotted mixed marked/), - my $deltaAngle=6.283/$N; - for (my $i = 0; $i < $N; $i++) { - my $x1 = $centerX + $radius * sin($i * $deltaAngle); - my $y1 = $centerY + $radius * cos($i * $deltaAngle); - my $x2 = $centerX+ $radius * sin( ($i + $deltaN) * $deltaAngle); - my $y2 = $centerY + $radius * cos( ($i + $deltaN)* $deltaAngle); - my $linetype = $lineTypes[$i%5]; - $mw->mapinfo($name, 'add', 'line', $linetype, 1+$i%3, +$x1,$y1,$x2,$y2); - } -} # end of createMapInfo - -sub test_mapitems { - my @mapinfoNames = @_; - &log (-1000, "#---- Start of test_mapitems ----\n"); - my @maps = $zinc->find('withtype', 'map'); - my $counter=0; - foreach my $map (@maps) { - &test_eval (1, "itemconfigure", $map, -mapinfo => $mapinfoNames[$counter]); - if ($counter == $#maps) { $counter=0 } - $counter++; - } - &log (0, "#---- End of test_mapitems ----\n"); -} # end test_mapitems - -## testing the returned value of coords -sub test_coords { - &log (-1000, "#---- Start of test_coords ----\n"); - foreach my $it ($zinc->find('withtag','*')) { - $zinc->remove($it); - } - ## creationg again items - &creating_items; - foreach my $type ($zinc->add()) { - next if $type eq 'map'; ## map item does not support coords method - my ($it) = $zinc->find('withtype',$type); - my @coordsAll= &test_eval (1, "coords", $it); - my $coordsAll = &printableArray(@coordsAll); - &log (1, "=> $coordsAll\n"); - my @coordsContour= &test_eval (1, "coords", $it,0); # all items have 1 contour - my $coordsContour = &printableArray(@coordsContour); - &log (1,"=> $coordsContour\n"); - my @coordsPoint= &test_eval (1, "coords", $it,0,0); # all items have 1 contour with at least one point - my $coordsPoint = &printableArray(@coordsPoint); - &log (1,"=> $coordsPoint\n"); - } - &log (0, "#---- End of test_coords ----\n"); -} - -sub parseTestsOpt { - my ($opt) = @_; - my @tests; - if ($opt eq '') { - print "Availables tests are:\n"; - while (@testsList) { - my $i = shift @testsList; - my $comment = shift @testsList; - print "\t$i => $comment\n"; - } - exit; - } elsif ( $opt eq 'all' ) { ## default! - &log (0, "# all tests will be passed through\n"); - @tests = sort keys %testsHash; - } elsif ( $opt =~ /^\d+(,\d+)*$/ ) { - @tests = split (/,/ , $opt); - my $testnumb = (scalar @testsList) / 2; - foreach my $test (@tests) { - die "tests num must not exceed $testnumb" if $test > $testnumb; - } - &log(0, "# Tests to be done:\n"); - foreach my $test (@tests) { - &log(0, "\t# $test => " . $testsHash{$test} . "\n"); - } - } else { - print "bad -tests value. Must be a list of integer separated by ,\n"; - &usage; - } - return @tests; -} # end of parseTestsOpt - - - -# ---------- TEST ------------------ -# the following code must be coherent with the tests list described -# on the very beginning of this file (see @testsList definition) - -&createMapInfo ('firstmap', 50, 20, 200, 200, 300); -&createMapInfo ('secondmap', 12, 3, 200, 300, 50); - -sub theTest { - if ($tests{1}) { - &test_mapitems ('firstmap', 'secondmap'); # should be done before really testing map items attributes - } - # #### &test_labelcontent; # should be done before really testing track/waypoint/tabular items attributes - - if ($tests{2}) { - &test_every_field_attributes; - } - - if ($tests{3}) { - &test_attributes; # on peut configurer tous les attributs - } - - ### we SHOULD test that setting a bad type value ofr an option does not core dump zinc! - - if ($tests{4}) { - &test_cloning; # we test that cloning items and modifiyng/removing them does not core dump - } - - ### we should also test multicontour curves - if ($tests{5}) { - &test_coords; - } - -# #### &test_fonts; ## and specially big fonts with render = 1; -# #### &test_path_tags; -# #### &test_illegal_tags; - -# #### &test_illegal_call -# for example: -# calling a method for an non-existing item -# getting coords, contours, fields, etc... of non-existing index -# -# cloning, deleting topgroup -# -} - -sub getMemoryUsage { - open (PROC, "/proc/$$/status"); - my ($totalMemory,$dataMemory); - while () { - if (/^VmSize:\s+(\d+)/) { - $totalMemory = $1; - } - elsif (/^VmData:\s+(\d+)/) { - $dataMemory = $1; - last; - } - } - close PROC; - return ($totalMemory,$dataMemory); -} - - - -if ($opt_memoryleak) { - my $iteration = 0; - while (1) { - my ($total,$data) = &getMemoryUsage; - ## get here the current memory state - &log(-1000, "#---- MemoryState iteration=$iteration totalMemory=$total dataMemory=$data ----\n"); - $iteration++; - &theTest; - } -} else { - &theTest; -} - - -&log (0, "#---- End of test_no_crash ----\n"); - -MainLoop(); diff --git a/Perl/t/testdoc.pl b/Perl/t/testdoc.pl deleted file mode 100644 index 590774f..0000000 --- a/Perl/t/testdoc.pl +++ /dev/null @@ -1,274 +0,0 @@ -#!/usr/bin/perl -w -# $Id$ -# This script verifies the conformity of the reference manual with -# some types informations available inside ZincTk -# It has been developped by C. Mertz - -# limitations: this script makes some very strong assumptions -# on the latex Zinc reference manual formating! -# However if the formating changes, it should be -# simple to modify the &scanDoc function! -# -# What this script currently does: -# - verifies that all Zinc options are documented -# - verifies that all items attributes (and their type) are documented -# - verifies that all field attributes options (and their type) are documented -# - verifies that all documented options and attributes really exists -# - verifies that all documented types are refered to in the doc -# It also checks that options, attributes and types are documented in alphabetical order -# It is heavily based on meta information available directly from zinc -# -# How to use it: -# testdoc.pl path_to_refman.tex - -use Tk; -use Tk::Zinc; - -use strict; - -print "------- Testing conformity of refman.tex and meta-information from zinc Version $Tk::Zinc::VERSION\n"; - -my $mw = MainWindow->new(); - -# Creating the zinc widget -# NB: this widget will not be displayed! It is only used for creating items -# and getting some internal information about attributes/options and types. - -my $zinc = $mw->Zinc(-width => 1, -height => 1,); - -# Creating an instance of every item type -my %itemtypes; - -# These Items have fields! So the number of fields must be given at creation time -foreach my $type qw(tabular track waypoint) { - $itemtypes{$type} = $zinc->add($type, 1, 1); -} - -# These items needs no specific initial values -foreach my $type qw(group icon map reticle text window) { - $itemtypes{$type} = $zinc->add($type, 1); -} - -# These items needs some coordinates at creation time -# However curves usually needs more than 2 points. -foreach my $type qw(arc curve rectangle) { - $itemtypes{$type} = $zinc->add($type, 1, [0,0 , 1,1]); -} -# Triangles item needs at least 3 points for the coordinates -foreach my $type qw(triangles) { - $itemtypes{$type} = $zinc->add($type, 1, [0,0 , 1,1 , 2,2]); -} - - -my %zinc2doc; # a hash recording every discrepency between attribute/option - # type between the doc and TkZinc -my %documentedOptions; -my %itemAttributeDoc; -my %documentedTypes; -my %usedTypes; # hash recording all refered types in the doc - -die "missing refman.tex path_name as unique argument to this script" unless defined $ARGV[0]; - - -&scanDoc ($ARGV[0]); - -sub scanDoc { - my ($filename) = @_; - open (DOC, $filename) or die "unable to open " . $filename . "\n"; - my $current_item = 0; - my $prev_attribute = 0; - my $prev_type = 0; - - while () { - if ( /^\\attribute\{(\w+)\}\{(\w+)\}\{(\w+)\}/ ) { - my $item = $1; - my $attribute = $2; - my $type = $3; - $itemAttributeDoc{$item}{-$attribute} = $type; - if ($item eq $current_item) { - if ($attribute lt $prev_attribute) { - print "W: attributes $prev_attribute and $attribute are not in alphabetical order for $item\n"; - } - } - else { - $current_item = $item; - $prev_attribute = $attribute; - } - } - elsif ( /^\\option\{(\w+)\}\{(\w+)\}\{(\w+)\}/ ) { - my $optionName = $1; - my $databaseName = $2; - my $databaseClass = $3; - $documentedOptions{-$optionName} = $databaseClass; - } - elsif ( /^\\attrtype\{(\w+)\}/ ) { - my $type = $1; - $documentedTypes{$type} = $type; - if ($type lt $prev_type) { - print "W: type $prev_type and $type are not in alphabetical order\n"; - } - $prev_type = $type; - } - } -} - -sub testAllOptions { - my @options = $zinc->configure(); - my %options; - # we use this hashtable to check that all documented options - # are matching all existing options in TkZinc - - for my $elem (@options) { - my ($optionName, $optionDatabaseName, $optionClass, $default, $optionValue) = @$elem; - $options{$optionName} = [$optionClass, $default, "", $optionValue]; - } - - foreach my $optionName (sort keys %options) { - my ($optionType, $readOnly, $empty, $optionValue) = @{$options{$optionName}}; - # $empty is for provision by Zinc - - if (!defined $documentedOptions{$optionName}) { - print "E: $optionName ($optionType) of Zinc IS NOT DOCUMENTED!\n"; - $options{$optionName} = undef; - next; - } - if ($documentedOptions{$optionName} ne $optionType) { - print "W: $optionName has type $optionType inside ZincTk and type $documentedOptions{$optionName} inside Doc\n"; - $zinc2doc{$optionType}=$documentedOptions{$optionName}; - } -# $attributes{$attributeName} = undef; - $documentedOptions{$optionName} = undef; - } - - foreach my $unexistingDocOpt (sort keys %documentedOptions) { - if (defined $documentedOptions{$unexistingDocOpt}) { - print "E: The Documented Option \"$unexistingDocOpt\" DOES NOT EXIST!\n"; - } - } -} - -sub testAllAttributes { - my ($item) = @_; - - my %documentedAttributes = %{$itemAttributeDoc{$item}}; - my @attributes = $zinc->itemconfigure($itemtypes{$item}); - - my %attributes; - # we use this hashtable to check that all documented attributes - # are matching all existing attributes in TkZinc - - # verifying that all referenced types are defined - # and storing used types - foreach my $attribute (sort keys %documentedAttributes) { - my $type = $documentedAttributes{$attribute}; - $usedTypes{$type} = 1; - print "E: type $type ($attribute of $item) is not documented\n" unless $documentedTypes{$type}; - } - - foreach my $elem (@attributes) { - my ($attributeName, $attributeType, $readOnly, $empty, $attributeValue) = @$elem; - $attributes{$attributeName} = [$attributeType, $readOnly, $empty, $attributeValue]; - } - - foreach my $attributeName (keys %attributes) { - my ($attributeType, $readOnly, $empty, $attributeValue) = @{$attributes{$attributeName}}; - # $empty is for provision by Zinc - - if (!defined $documentedAttributes{$attributeName}) { - print "E: $attributeName ($attributeType) of item $item IS NOT DOCUMENTED!\n"; - $attributes{$attributeName} = undef; - next; - } - - if ($documentedAttributes{$attributeName} ne $attributeType) { - print "W: $attributeName has type $attributeType inside ZincTk and type $documentedAttributes{$attributeName} inside Doc\n"; - $zinc2doc{$attributeType}=$documentedAttributes{$attributeName}; - } -# $attributes{$attributeName} = undef; - $documentedAttributes{$attributeName} = undef; - } - - foreach my $unexistingDocAttr (sort keys %documentedAttributes) { - if (defined $documentedAttributes{$unexistingDocAttr}) { - print "E: The Documented Attribute \"$unexistingDocAttr\" DOES NOT EXIST!\n"; - } - } -} - - -sub testFieldAttributes { - my %documentedAttributes = %{$itemAttributeDoc{"field"}}; - my @attributes = $zinc->itemconfigure($itemtypes{track},0); - - my %attributes; - # we use this hashtable to check that all documented fields attributes - # are matching all existing fields attributes in TkZinc - - # verifying that all referenced types are defined - # and storing used types - foreach my $attribute (sort keys %documentedAttributes) { - my $type = $documentedAttributes{$attribute}; - $usedTypes{$type} = 1; - print "E: type $type ($attribute of 'field') is not documented\n" unless $documentedTypes{$type}; - } - - - foreach my $elem (@attributes) { - my ($attributeName, $attributeType, $readOnly, $empty, $attributeValue) = @$elem; - $attributes{$attributeName} = [$attributeType, $readOnly, $empty, $attributeValue]; - } - - foreach my $attributeName (keys %attributes) { - my ($attributeType, $readOnly, $empty, $attributeValue) = @{$attributes{$attributeName}}; - # $empty is for provision by Zinc - - if (!defined $documentedAttributes{$attributeName}) { - print "E: $attributeName ($attributeType) of field IS NOT DOCUMENTED!\n"; - $attributes{$attributeName} = undef; - next; - } - - if ($documentedAttributes{$attributeName} ne $attributeType) { - print "W: $attributeName of field has type $attributeType inside ZincTk and type $documentedAttributes{$attributeName} inside Doc\n"; - $zinc2doc{$attributeType}=$documentedAttributes{$attributeName}; - } - $documentedAttributes{$attributeName} = undef; - } - - foreach my $unexistingDocAttr (sort keys %documentedAttributes) { - if (defined $documentedAttributes{$unexistingDocAttr}) { - print "E: The Documented Field Attribute \"$unexistingDocAttr\" DOES NOT EXIST!\n"; - } - } -} - -sub verifyingAllDefinedTypesAreUsed { - foreach my $type (sort keys %documentedTypes) { - print "W: documented type $type is never refered to in the doc\n" unless $usedTypes{$type}; - } -} - -print "--- TkZinc Options -----------------------------------------\n"; -&testAllOptions; -print "--- Field Attributes ---------------------------------------\n"; - -&testFieldAttributes; - -foreach my $type (sort keys %itemtypes) { - print "--- Item $type -------------------------------------------------\n"; - &testAllAttributes($type); -} - -&verifyingAllDefinedTypesAreUsed; - -print "------- Summary of type discrepencies between Doc and Zinc --------\n"; -printf "%15s |%15s\n", "zinctype","doctype"; -foreach my $typezinc (sort keys %zinc2doc) { - printf "%15s |%15s\n", $typezinc,$zinc2doc{$typezinc}; -} - - -# MainLoop(); - - -1; diff --git a/Perl/t/text.t b/Perl/t/text.t deleted file mode 100644 index b8893db..0000000 --- a/Perl/t/text.t +++ /dev/null @@ -1,161 +0,0 @@ -#!/usr/bin/perl -w - -# -# $Id: text.t,v 1.6 2004-05-07 13:53:00 mertz Exp $ -# Author: Christophe Mertz -# - -# testing text item - -# this script can be used with an optionnal argument, an integer giving -# the delay in seconds during which the graphic updates will be displayed -# this is usefull for visual inspection! - -my $mw; -BEGIN { - if (!eval q{ -# use Test::More qw(no_plan); - use Test::More tests => 69; - 1; - }) { - print "# tests only work properly with installed Test::More module\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - use Tk::Zinc; - 1; - }) { - print "unable to load Tk::Zinc"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - $mw = MainWindow->new(); - 1; - }) { - print "# tests only work properly when it is possible to create a mainwindow in your env\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } -} - -use strict; - -my $zinc = $mw->Zinc(-render => 1, - -width => 400, -height => 1200)->pack; - -like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc has been created"); - - -my $g1 = $zinc->add('group',1, -tags => "gr1"); - - -my $TEXT = ""; - -my @families = $mw->fontFamilies; -#print "families=@families\n"; - -my $family=""; -if ( grep /^verdana$/i , @families) { - $family = "verdana"; -# $family = "helvetica"; -} elsif ( grep /^helvetica$/i , @families) { - $family = "helvetica"; -} elsif ( grep /^arial$/i , @families) { - $family = "arial"; -} -#print "family=$family\n"; - -my $topLevel = $mw->Toplevel(); -$topLevel->title("testing all ascii glyphs of $family"); - -my $zinc0 = $topLevel->Zinc(-render => 1, - -width => 300, - -height => 400,)->pack; -like ($zinc, qr/^Tk::Zinc=HASH/ , "zinc0 has been created"); - -$zinc0->fontCreate("fonta", -family => $family, -size => -20, -weight => 'normal'); - - -foreach my $row (2..15) { - my $string = ""; - foreach my $col (0..15) { - $string .= chr($row*16+$col); - } - $zinc0->add('text', 1, -position => [10,$row*20-40], - -text => $string, -font => 'fonta'); - $zinc0->update; - &pass("adding text item n°$row with a $family font of size 20 and normal weight"); -} - - -### creating text items with many different fonts: - -my $size = 8; -my $y = 10 ; - -$zinc->fontCreate("font$size", -family => $family, -size => -$size, -weight => 'normal'); - - -### creating text items with many different fonts: -$zinc->add('text', $g1, -position => [10,$y], -tags => ["txt$size"], -font => "font$size", - -text => "$size pixels $family"); -$zinc->remove('txt8'); -$zinc->fontDelete("font$size"); -$zinc->fontCreate("font$size", -family => $family, -size => -$size, -weight => 'normal'); -$zinc->add('text', $g1, -position => [10,$y], -tags => ["txt$size"], -font => "font$size", - -text => "$size pixels $family"); - - - - - -foreach my $size (9..60) { - $zinc->fontCreate("font$size", -family => $family, -size => -$size, -weight => 'normal'); - $zinc->add('text', $g1, -position => [10,$y], -tags => ["txt$size"], -font => "font$size", - -text => "$size pixels $family"); - $zinc->update; - - # deleting both the font and the text item and recreating it 10 times - foreach my $count (1..10) { - $zinc->fontDelete("font$size"); - $zinc->remove('txt8'); - $zinc->fontCreate("font$size", -family => $family, -size => -$size, -weight => 'normal'); - $zinc->add('text', $g1, -position => [10,$y], -tags => ["txt$size"], -font => "font$size", - -text => "$size pixels $family"); - $zinc->update; - } - &pass("creating and deleting 10 times a text item with a $family font of size $size"); - $y += $size; -} - - -&wait; - -## we should certainly test much much other things! - - - -sub wait { - $zinc->update; - ok (1, $_[0]); - - my $delay = $ARGV[0]; - if (defined $delay) { - $zinc->update; - if ($delay =~ /^\d+$/) { - sleep $delay; - } else { - sleep 1; - } - } - -} - - - -diag("############## end of text test"); diff --git a/Perl/t/traceutils.t b/Perl/t/traceutils.t deleted file mode 100644 index 0636037..0000000 --- a/Perl/t/traceutils.t +++ /dev/null @@ -1,89 +0,0 @@ -#!/usr/bin/perl -w - -# -# $Id: traceutils.t,v 1.2 2004-05-07 16:53:43 mertz Exp $ -# Author: Christophe Mertz -# - -# testing Tk::Zinc::TraceUtils utilities - -#use Tk::Zinc::TraceUtils; -use strict; - -BEGIN { - if (!eval q{ -# use Test::More qw(no_plan); - use Test::More tests => 14; - 1; - }) { - print "# tests only work properly with installed Test::More module\n"; - print "1..1\n"; - print "ok 1\n"; - exit; - } - if (!eval q{ - use Tk::Zinc::TraceUtils; - 1; - }) { - print "unable to load Tk::Zinc::TraceUtils"; - print "1..1\n"; - print "ok 1\n"; - exit; - } -} - - - -#### creating different images, bitmaps and pixmaps... - -my $arg; - -$arg = "1"; -is (&Item ($arg), $arg, "testing " . $arg); - -SKIP: { - my $mw; - skip "not able to create a MainWindow", 3 if !eval q{$mw = MainWindow->new()} ; - require Tk::Font; - my $font = $mw->fontCreate("testfont", -family => "Helvetica"); - - like ($font, qr/^testfont/, "font creation"); - is (&Item ($font), "'testfont'", "testing " . "testfont"); # not so sure about this result! - is (&List (-font => $font), "(-font => 'testfont')", "(-font => afont)"); -} - -$arg = "()"; -is (&List (eval $arg), $arg, "empty list: ". $arg); - -$arg = "(-option_without_value)"; -is (&List (eval $arg), $arg, $arg); - -$arg = "(1, 2, 3, 4)"; -is (&List (eval $arg), $arg, $arg); - -$arg = "(-1, -2, -3, -4)"; -is (&List (eval $arg), $arg, $arg); - -$arg = "(1.2, -2, .01, -1.2e+22, 1.02e+34)"; - -is (&List (eval $arg), ($arg =~ s/\.01/0.01/ , $arg ), $arg); - -$arg = "('-1aa' => -2, '-a b', -1.2)"; -is (&List (eval $arg), $arg, $arg); - -$arg = "(-option => -2, -option2 => -1.2, -option3)"; -is (&List (eval $arg), $arg, $arg); - -$arg = "('icon', 1, -priority => 210, -visible => 1)"; -is (&List (eval $arg), $arg, $arg); - -$arg = "('text', 1, -font => '-adobe-helvetica-bold-r-normal-*-120-*-*-*-*-*-*')"; -is (&List (eval $arg), $arg, $arg); - - -$arg = "-option, -2, -option2, -1.2, -option3"; -is (&Array (eval "(".$arg.")"), "[".$arg."]", "[".$arg."]"); - - - -diag("############## Tk::Zinc::TraceUtils test"); diff --git a/Python/library/Zinc.py.in b/Python/library/Zinc.py.in deleted file mode 100644 index f26af6a..0000000 --- a/Python/library/Zinc.py.in +++ /dev/null @@ -1,452 +0,0 @@ -# -# Zinc.py -- Python interface to the tkzinc widget. -# -# Authors : Frederic Lepied, Patrick Lecoanet -# Created Date : Thu Jul 22 09:36:04 1999 -# -# $Id$ -# -# -# Copyright (c) 1999 CENA -- -# -# This code is free software; you can redistribute it and/or -# modify it under the terms of the GNU Library General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# 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. -# -# You should have received a copy of the GNU Library General Public -# License along with this code; if not, write to the Free -# Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -# -# - -__version__ = "$Revision$" - -import string, types -from Tkinter import * -from Tkinter import _cnfmerge, _flatten -import traceback - -ZINC_NO_PART=-1 -ZINC_CURRENT_POSITION=-2 -ZINC_SPEED_VECTOR=-3 -ZINC_LEADER=-4 -ZINC_CONNECTION=-5 - -# current part dictionnary -ZINC_DPART = { 'position' : ZINC_CURRENT_POSITION, - 'speedvector' : ZINC_SPEED_VECTOR , - 'leader' : ZINC_LEADER, - 'connection' : ZINC_CONNECTION} -# notes : 'field' will be return when currentpart is a field - -def havetkzinc(window): - '''load Zinc dynamic sharable object library , test if everything is ok -if ok :return zinc version -if nok : return 0 ''' - try: - window.tk.call('load', '@Tkzinc_LIB_FILE@') - # Call a function from the package to autoload it - # and verify that all is OK. - sversion = window.tk.call('zinc') + " Zinc.py %s" % __version__ - except TclError: - traceback.print_exc() - return 0 - return sversion - -class Zinc(Widget): - def __str__(self): - return("Zinc instance") - def __init__(self, master=None, cnf={}, **kw): - Widget.__init__(self, master, 'zinc', cnf, kw) - self.items = {} - - def add(self, itemType, *args, **kw): -# if len(args) != 0: -# cnf = args[-1] -# else: -# cnf={} -# if type(cnf) in (DictionaryType, TupleType): -# args = args[:-1] -# else: -# cnf = {} - #args = _flatten(args) - args=list(args) - args=args+list(self._options(kw)) - return self.tk.getint( - self.tk.call(self._w, 'add', itemType,*args)) - - def addtag(self, *args): - self._do('addtag', args) - - def addtag_above(self, newtag, tagOrId): - self.addtag(newtag, 'above', tagOrId) - - def addtag_all(self, newtag): - self.addtag(newtag, 'all') - - def addtag_atpoint(self, newtag, x, y, halo=None, start=None): - self.addtag(newtag, 'atpoint', x, y, halo, start) - - def addtag_atpriority(self, newtag, pri): - self.addtag(newtag, 'atpriority', pri) - - def addtag_below(self, newtag, tagOrId): - self.addtag(newtag, 'below', tagOrId) - - def addtag_enclosed(self, newtag, x1, y1, x2, y2): - self.addtag(newtag, 'enclosed', x1, y1, x2, y2) - - def addtag_overlapping(self, newtag, x1, y1, x2, y2): - self.addtag(newtag, 'overlapping', x1, y1, x2, y2) - - def addtag_withtag(self, newtag, tagOrId): - self.addtag(newtag, 'withtag', tagOrId) - - def addtag_withtype(self, newtag, type): - self.addtag(newtag, 'withtype', type) - - def anchorxy(self, *args): - self._do('anchorxy', args) - - def bbox(self, *args): - self._do('bbox', args) - - def becomes(self, *args): - self._do('becomes', args) - -# def bind(self): -# pass - - def bind_tag(self, tagOrId, sequence=None, func=None, add=None): - '''return a funcid which can be usefull for unbinding''' - return self._bind((self._w, 'bind', tagOrId), - sequence, func, add) - -# def cget(self): -# pass - - def chggroup(self, *args): - self._do('chggroup', args) - - def clone(self, *args): - self._do('clone', args) - -# def configure(self): -# pass - - def coords(self, *args): - self._do('coords', args) - - def currentpart(self): - '''return a string (result from zinc current part function) and an -integer representing either the number of the field either the number of the -item part either ZINC_NO_PART''' - scurrentp = self._do('currentpart') - if scurrentp == "": - rvalue = ZINC_NO_PART - else: - try: - rvalue = string.atoi(scurrentp) - except: - try: - rvalue = ZINC_DPART[scurrentp] - except: - rvalue = ZINC_NO_PART - else: - # string to integer succeeded - scurrentp = "field" - return(scurrentp,rvalue) - - def dtag(self, *args): - self._do('dtag', args) - - def find(self, *args): - return self._getints(self._do('find', args)) or () - - def find_above(self, tagOrId): - return self.find('above', tagOrId) - - def find_all(self): - return self.find('all') - - def find_atpoint(self, x, y, halo=None, start=None): - return self.find('atpoint', x, y, halo, start) - - def find_atpriority(self, pri): - return self.find('atpriority', pri) - - def find_below(self, tagOrId): - return self.find('below', tagOrId) - - def find_enclosed(self, x1, y1, x2, y2): - return self.find('enclosed', x1, y1, x2, y2) - - def find_overlapping(self, x1, y1, x2, y2): - return self.find('overlapping', x1, y1, x2, y2) - - def find_withtag(self, tagOrId): - return self.find('withtag', tagOrId) - - def find_withtype(self, type): - return self.find('withtag', type) - - def gettags(self, *args): - return self.tk.splitlist(self._do('gettags', args)) - - def group(self, *args): - self._do('group', args) - - def hasanchors(self, *args): - self._do('hasanchors', args) - - def hasfields(self, *args): - self._do('hasanchors', args) - - def hasparts(self, *args): - self._do('hasanchors', args) - -# def hastag(self): -# pass - - def itemcget(self, tagOrId, option): - return self._do('itemcget', (tagOrId, '-'+option)) - - def itemfieldcget(self, tagOrId, field, option): - return self._do('itemcget', (tagOrId, field, '-'+option)) - - def itemconfigure(self, tagOrId, field=None, **kw): - '''either get the dictionnary of possible attributes (if kw is None) -either allow to set Items attributes or Field attributes ''' - if not kw: - cnf = {} - for x in self.tk.split( - field != None and self._do('itemconfigure', (tagOrId, field)) or - self._do('itemconfigure', (tagOrId,))): - cnf[x[0][1:]] = (x[0][1:],) + x[1:] - return cnf - if field != None: - self._do('itemconfigure', (tagOrId, str(field),) - + self._options({}, kw)) - else: - self._do('itemconfigure', (tagOrId,) + self._options({},kw)) - - # _dp voir si cette instruction est a execute ici - # permet de creer un synonyme de itemconfigure - itemconfig = itemconfigure - - def loweritem(self, *args): - self._do('lower', args) - - def monitor(self, *args): - self._do('monitor', args) - - def raiseitem(self, *args): - self._do('raise', args) - - def remove(self, *args): - self._do('remove', args) - - def rotate(self, *args): - self._do('rotate', args) - - def scale(self, xFactor=None, yFactor=None, tagOrId=None): - if yFactor == None: - return self.tk.getdouble(self._do('scale')) - else: - if tagOrId == None: - self._do('scale', (xFactor, yFactor)) - else: - self._do('scale', (tagOrId, xFactor, yFactor)) - - def tdelete(self, *args): - self._do('tdelete', args) - - def transform(self, *args): - # self._getints(self._do('transform', args)) - return self._getdoubles(self._do('transform', args)) - - def translate(self, dx=None, dy=None, tagOrId=None): - if dx == None: - return self._getints(self._do('translate')) - else: - if tagOrId == None: - self._do('translate', (dx, dy)) - else: - self._do('translate', (tagOrId, dx, dy)) - - def treset(self, *args): - self._do('treset', args) - - def trestore(self, *args): - self._do('trestore', args) - - def tsave(self, *args): - self._do('tsave', args) - - def type(self, tagOrId): - return self._do('type', (tagOrId,)) - - -class ZincItem: - def __init__(self, zinc, itemType, *args, **kw): - self.zinc = zinc - self.id = zinc.add(itemType, *args, **kw) - zinc.items[self.id] = self - - def __str__(self): - return str(self.id) - - def __repr__(self): - return str(self.id) - - def delete(self): - del self.zinc.items[self.id] - try: - self.zinc.remove(self.id) - except: - pass - def __getitem__(self, key): - '''allow to get attribute by self["key"] ''' - if ( key == "coords" ): - return self.zinc.coords() - return self.zinc.itemcget(self.id, key) - - def __setitem__(self, key, value): - '''allow to set item attrbutes, eg. for a track position attributes -just writing : -a = ZincItem(myzinc, ...) -a["position"] = (x,y) -Notes : when setting multiple attributes using itemconfigure is more efficient ''' - if ( key is "coords" ): - self.zinc.coords(self.id,value) - else: - self.zinc.itemconfigure(self.id, **{key:value}) - - def keys(self): - if not hasattr(self, '_keys'): - self._keys = {} - config=self.zinc.itemconfig(self.id) - for x in config.keys(): - self._keys[x] = config[x][1] - return self._keys - - def has_key(self, key): - return key in self.keys() - - def bind(self, sequence=None, command=None, add=None): - '''return a funcid which can be used to unbind -notes: unbinding can be done by bind("","") or using native tkinter -unbind method ''' - return(self.zinc.bind_tag(self.id, sequence, command, add)) - - def cget(self, attr): - return self.zinc.itemcget(self.id, attr) - - def fieldcget(self, field, attr): - return self.zinc.itemfieldcget(self.id, field, attr) - - def itemconfigure(self, field=None, **kw): - self.zinc.itemconfigure(self, field,**kw) - - def rotate(self, factor): - return self.zinc.rotate(factor,self.id) - - def scale(self, xFactor=None, yFactor=None): - return self.zinc.scale(xFactor, yFactor,self.id) - - def translate(self, dx=None, dy=None): - self.zinc.translate(self.id,dx,dy) - -class Arc(ZincItem): - def __init__(self, zinc, *args, **kw): - ZincItem.__init__(self, zinc, 'arc', *args, **kw) - -class Group(ZincItem): - def __init__(self, zinc, *args, **kw): - ZincItem.__init__(self, zinc, 'group', *args, **kw) - -class Icon(ZincItem): - def __init__(self, zinc, *args, **kw): - ZincItem.__init__(self, zinc, 'icon', *args, **kw) - -class Map(ZincItem): - def __init__(self, zinc, *args, **kw): - ZincItem.__init__(self, zinc, 'map', *args, **kw) - -class Curve(ZincItem): - def __init__(self, zinc, *args, **kw): - ZincItem.__init__(self, zinc, 'curve', *args, **kw) - -class Rectangle(ZincItem): - def __init__(self, zinc, *args, **kw): - ZincItem.__init__(self, zinc, 'rectangle', *args, **kw) - -class Reticle(ZincItem): - def __init__(self, zinc, *args, **kw): - ZincItem.__init__(self, zinc, 'reticle', *args, **kw) - -class Tabular(ZincItem): - def __init__(self, zinc, *args, **kw): - ZincItem.__init__(self, zinc, 'tabular', *args, **kw) - -class Text(ZincItem): - def __init__(self, zinc, *args, **kw): - ZincItem.__init__(self, zinc, 'text', *args, **kw) - -class Track(ZincItem): - def __init__(self, zinc, *args, **kw): - ZincItem.__init__(self, zinc, 'track', *args, **kw) - -class WayPoint(ZincItem): - def __init__(self, zinc, *args, **kw): - ZincItem.__init__(self, zinc, 'waypoint', *args, **kw) - - -# Class to hold mapinfos used by the Map Item class -class Mapinfo: - def __init__(self, interp, *args): - self.interp=interp.tk - apply(self.interp.call, ('mapinfo', self, 'create')) - - def __repr__(self): - return `id(self)` - - def add_text(self, text_style, line_style, x, y, text): - self.interp.call('mapinfo', self, 'add', 'text', text_style, - line_style, x, y, text) - - def add_line(self, line_style, width, x1, y1, x2, y2): - self.interp.call('mapinfo', self, 'add', 'line', line_style, - width, x1, y1, x2, y2) - - def add_arc(self, line_style, width, cx, cy, radius, start, extent): - self.interp.call('mapinfo', self, 'add', 'arc', line_style, - width, cx, cy, radius, start, extent) - - def scale(self, factor): - self.interp.call('mapinfo', self, 'scale', factor) - - def translate(self, xAmount, yAmount): - self.interp.call('mapinfo', self, 'translate', xAmount, yAmount) - -class Videomap (Mapinfo): - def __init__(self, tk, *args): - self.tk=tk.tk - args=args + (self,) - self.tk.call('videomap', 'load', *args ) - -# ---- self-test ---------------------------------------------------------- -if __name__ == '__main__': - from Tkinter import * - tk = Tk() - zincversion = havetkzinc(tk) - if zincversion : - print "Zinc version [%s] seems ok." % zincversion - -# Zinc.py ends here diff --git a/README b/README deleted file mode 100644 index b88892a..0000000 --- a/README +++ /dev/null @@ -1,294 +0,0 @@ -$Id$ - - - - - *===========================================* - The TkZinc widget version 3.3 - *===========================================* - - -WHAT IS THIS? - - TkZinc is a canvas like widget extension to Tcl/Tk. It adds -support for ATC displays, provides structured assembly of -items, transformations, clipping, and openGL based rendering -features such as gradients and alpha blending. - - It is currently available on Unices (tested on Linux), -Windows and Mac OSX (with X11 and fink). - - -WHERE DOES IT COME FROM? - - The newest version is found at: http://www.tkzinc.org/ - It should be at least available in source form in a file - named Tkzinc.tgz. - Distribution specific packages may also be available for - Debian/Mandrake/Red Hat distributions, most likely for stable - versions. - - For Tcl/Tk users, TkZinc is also available as a multi-plateforme - (linux/windows) starkit on http://www.tkzinc.org/ - For Perl/Tk users, TkZinc is available on the CPAN, see for example - on http://search.cpan.org/search?query=TkZinc&mode=all - - As a convenience the documentation (pdf+html) is made available - on the web site as a separate package. - - -BUILDING AND INSTALLATION FOR TCL/TK - - -0. You need a working Tcl/Tk distribution (version >= 8.4). You can either grab - it using your regular package manager, or build it and install it from scratch. - - On a Linux system, you need tcl tcl-dev tk tk-dev packages. - - On MacOSX you need: - - fink with tcltk and tcltk-dev package (http://fink.sf.net) - - tcl/tk sources, though you are _not_ required to compile and install them. - tcl/tk sources are needed because some required files are missing in the packages (tclInt.h and tkInt.h, - if you know how to get those files with fink, submit a suggestion to the maintainers). - I couldn't install them using fink, d/l them instead: - http://prdownloads.sourceforge.net/fink/direct_download/source - - X11 et X11 sdk from Apple (http://www.apple.com/macosx/x11/) - - From sources or on Windows, get, build and _install_ the Tcl/Tk distribution. - On Windows there is currently an incompatibility when using a TkZinc compiled under mingw32 with - a core Tcl/Tk compiled with visual C++. You need to grab a Tcl/Tk - compiled with the same environment as TkZinc. - - -1. Unpack the distribution - - On Unix/Linux/MacOSX: - - tar zxf Tkzinc.tgz - - On Windows: - - Use WinZip or something similar to unpack - - This creates a directory Tkzinc with all the - needed files. This directory should be in the same - directory as the Tcl/Tk sources. - - -2. Configure - - On Unix/Linux: - - cd Tkzinc - ./configure

', sub { print "perfs: ", join(',', $zinc->monitor()), "\n" }); -$mw->Tk::bind('', sub { $zinc->remove($mp3); }); -$mw->Tk::bind('', sub { exit(0); }); -$zinc->focusFollowsMouse(); -MainLoop(); diff --git a/sandbox/logo.gif b/sandbox/logo.gif deleted file mode 100644 index ce78abd..0000000 Binary files a/sandbox/logo.gif and /dev/null differ diff --git a/sandbox/smooth.tcl b/sandbox/smooth.tcl deleted file mode 100644 index 9260f7b..0000000 --- a/sandbox/smooth.tcl +++ /dev/null @@ -1,34 +0,0 @@ -#!/usr/local/bin/wish -f - -load ../tkzinc3.2.so -package require Img - -set top 1 -set points "50 -150 100 -50 270 -130 220 -200 200 -180 180 -300 140 -320 70 -300" -set lw 3 - -set r [zinc .r -backcolor gray -relief sunken] -pack .r -expand t -fill both -.r configure -width 800 -height 500 -.r scale $top 1 -1 -#.r configure -drawbboxes t -set view [.r add group $top -tags controls] - - -set smooth [.r smooth $points] -set fit [.r fit $points 0.1] - - -set mp [.r add curve $view $smooth \ - -linecolor yellow -fillcolor tan -fillpattern AlphaStipple8 \ - -tags "bezier" -linewidth $lw] -set mp2 [.r add curve $view $fit \ - -linecolor yellow -fillcolor tan -fillpattern AlphaStipple8 \ - -tags "bezier" -linewidth $lw] -set poly [.r add curve $view $points -marker AtcSymbol9] -set poly2 [.r add curve $view $points -marker AtcSymbol9] - -.r translate $mp2 300 0 -.r translate $poly2 300 0 - -source "controls.tcl" diff --git a/sandbox/testarc.tcl b/sandbox/testarc.tcl deleted file mode 100644 index b48b537..0000000 --- a/sandbox/testarc.tcl +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/local/bin/wish -f - -load ../tkzinc3.2.so -package require Img - -set top 1 - -#image create photo logo -file logo.gif -#image create photo papier -file texture-paper.xpm -#image create photo penguin -file xpenguin.png -#image create photo papier -file texture-paper.xpm - -set r [zinc .r -backcolor gray -relief sunken -render 0] -pack .r -expand t -fill both -.r configure -width 800 -height 500 -#.r configure -drawbboxes t -.r scale $top 1 -1 -set view [.r add group $top -tags "controls"] -.r translate $view 200 -200 -set view2 [.r add group $top] -.r translate $view2 300 -200 - -set arc [.r add arc $view "50 -10 200 -100" -filled t -closed t -pieslice t \ - -fillcolor "white|darkslateblue" -linewidth 1 \ - -startangle 0 -extent 120] -#set arc [.r add arc $view "50 -10 200 -100" -filled t -closed t -pieslice t -fillcolor "#ff0000|#00ff00" -linewidth 0] -#.r add arc $view "60 -20 190 -90" -filled t -closed t -pieslice t -fillcolor "white|darkslateblue" -linewidth 1 -linecolor white - -#set arc2 [.r clone $arc -linecolor red -firstend "8 10 5"] -#.r rotate $arc2 10 -#.r translate $arc2 100 -100 - -#.r add icon $view2 -image penguin -set cliparc [.r add arc $view "-100 100 100 -100" -filled t \ - -fillcolor tan ] -.r lower $cliparc -#.r rotate $cliparc 20 0 0 -#.r translate $cliparc 100 -40 -#.r itemconfigure $view2 -clip $cliparc -bind .r <1> ".r rotate $cliparc [expr 3.14/3] 0 0" -source "controls.tcl" -.r bind $cliparc <1> {puts a} -puts "[ .r bind $cliparc <1> ]\n" - diff --git a/sandbox/testbezier.pl b/sandbox/testbezier.pl deleted file mode 100644 index 82948fc..0000000 --- a/sandbox/testbezier.pl +++ /dev/null @@ -1,190 +0,0 @@ -#!/usr/bin/perl -w - - -use Tk; -use Tk::Zinc; -use Controls; -use Tk::Photo; -require Tk::PNG; - - -$top = 1; -$lw = 8; -$arrow = [8, 10, 6]; - -# -# Cap, Filled, Border, Relief, Title -# -@show = ( - ['round', 0, 1, 'flat', 'CapRound'], - ['butt', 0, 1, 'flat', 'CapButt'], - ['projecting', 0, 1, 'flat', 'CapProjecting'], - ['round', 0, 1, 'sunken', 'Sunken'], - ['round', 0, 1, 'raised', 'Raised'], - ['round', 0, 1, 'groove', 'Groove'], - ['round', 0, 1, 'ridge', 'Ridge'], - ['round', 1, 1, 'roundsunken', 'RoundSunken'], - ['round', 1, 1, 'roundraised', 'RoundRaised'], - ['round', 1, 1, 'roundgroove', 'RoundGroove'], - ['round', 1, 1, 'roundridge', 'RoundRidge'], - ['round', 1, 1, 'sunkenrule', 'SunkenRule'], - ['round', 1, 1, 'raisedrule', 'RaisedRule'], - ['round', 1, 0, 'flat', 'Fill'], - ['round', 1, 1, 'flat', 'FillBorder']); - -$mw = MainWindow->new(); -#$logo = $mw->Photo(-file => "logo.gif"); -$papier = $mw->Photo(-file => "texture-paper.xpm"); - -$zinc = $mw->Zinc(-render => 1, - -lightangle => 120, - -borderwidth => 0, - -highlightthickness => 0, - -relief => 'sunken', - -takefocus => 1, - -backcolor => 'red' - # -tile => $papier - ); -$zinc->pack(-expand => 1, -fill => 'both'); -$zinc->configure(-width => 500, -height => 500); -$zinc->scale($top, 1, -1); - -$view = $zinc->add('group', $top, - -tags => 'controls'); -$clipbez = $zinc->add('bezier', $view, [20, -20, - 890, -20, - 890, -900, - 20, -400], - -linewidth => 0, - -filled => 1, - -fillcolor => 'tan'); -#$zinc->itemconfigure($view, -# -clip => $clipbez); - -# -# Create the model -# -$model = $zinc->add('group', $view); -$mp = $zinc->add('bezier', $model, [50, -150, - 100, -50, - 270, -130, - 220, -200, - 200, -180, - 180, -300, - 140, -160, - 70, -300], - -fillcolor => 'tan', - -tags => 'bezier', - -linewidth =>$lw); -#$zinc->add('rectangle', $model, [50, -150, 100, -50]); -@bbox = $zinc->bbox($mp); -@bbox = $zinc->transform($model, \@bbox); -$x = ($bbox[2] + $bbox[0]) / 2; -$y = $bbox[1] + 5; -$zinc->add('text', $model, - -text => 'CapRound', - -color => 'blue', - -alignment => 'center', - -anchor => 's', - -tags => 'title', - -position => [$x, $y]); - -# -# Now clone for each variation on the polygon -# -$col = 0; -$row = 0; -foreach $current (@show) { - ($cap, $filled, $border, $relief, $title) = @{$current}; - $grp = $zinc->clone($model); - $zinc->translate($grp, $col * 240, $row * (-290 - (2 * $lw))); - $zinc->itemconfigure($zinc->find('withtag', "$grp*bezier"), - -capstyle => $cap, - -filled => $filled, - -linewidth => $border ? $lw : 0, - -relief => $relief, - -linecolor => $relief eq 'flat' ? 'yellow' : 'tan'); - $zinc->itemconfigure($zinc->find('withtag', "$grp*title"), - -text => $title); - $col++; - if ($col >= 4) { - $col = 0; - $row++; - } -} - -# -# Suppress the model -# -$zinc->remove($model); - -my @coords = ( -10, 0, 40, 0, 70, 0, -70, 0, 80, 0, 80, 10, -80, 10, 80, 40, 80, 70, -80, 70, 80, 80, 70, 80, -70, 80, 40, 80, 10, 80, -10, 80, 0, 80, 0, 70, -0, 70, 0, 40, 0, 10, -0, 10, 0, 0, 10, 0); -$zinc->add('bezier', $view, \@coords); - -# -# Some optional graphic features -$closed = 0; -#set smooth 0 -$arrows = 'none'; - -sub toggle_arrows { - if ($arrows eq 'none') { - $arrows = 'first'; - $f = $arrow; - $l = ''; - } - elsif ($arrows eq 'first') { - $arrows = 'last'; - $f = ''; - $l = $arrow; - } - elsif ($arrows eq 'last') { - $arrows = 'both'; - $f = $arrow; - $l = $arrow; - } - elsif ($arrows eq 'both') { - $arrows = 'none'; - $f = ''; - $l = ''; - } - $zinc->itemconfigure('bezier', - -firstend => $f, - -lastend => $l) -} - - -sub toggle_closed { - $closed = !$closed; - foreach $ curve ($zinc->find('withtag', 'bezier')) { - if ($closed) { - @coords = $zinc->coords($curve, 0, 0); - $zinc->coords($curve, 'add', \@coords); - } - else { - $zinc->coords($curve, 'remove', -1) - } - } -} - -$zinc->Tk::focus(); - -$zinc->Tk::bind('', \&toggle_arrows); -$zinc->Tk::bind('', \&toggle_closed); - -$zinc->Tk::bind('', - sub {my $ev = $zinc->XEvent(); - my $it = $zinc->find('closest', $ev->x, $ev->y); - print "$it ", $zinc->verticeat($it, $ev->x, $ev->y), "\n"}); -$zinc->Tk::bind('', sub {Tk::break}); - -new Controls($zinc); -MainLoop(); diff --git a/sandbox/testbezier.tcl b/sandbox/testbezier.tcl deleted file mode 100644 index 4b1af0b..0000000 --- a/sandbox/testbezier.tcl +++ /dev/null @@ -1,131 +0,0 @@ -#!/usr/local/bin/wish -f - -load ../tkzinc3.2.so -package require Img - -set top 1 -set lw 8 -set arrow "8 10 6" - - -# -# Cap Filled Border Relief Title -# -set show {\ - {round f 1 flat CapRound}\ - {butt f 1 flat CapButt}\ - {projecting f 1 flat CapProjecting}\ - {round f 1 sunken Sunken}\ - {round f 1 raised Raised}\ - {round f 1 groove Groove}\ - {round f 1 ridge Ridge}\ - {round t 1 sunken FilledSunken}\ - {round t 1 raised FilledRaised}\ - {round t 1 groove FilledGroove}\ - {round t 1 ridge FilledRidge}\ - {round t 0 flat Fill}\ - {round t 1 flat FillBorder}} - -image create photo logo -file /usr/share/toccata/images/logo.gif -#image create photo papier -file /usr/share/toccata/images/dgtexture-dragstrip.xpm - -set r [zinc .r -backcolor gray -relief sunken] -pack .r -expand t -fill both -.r configure -width 1024 -height 800 -.r scale $top 1 -1 -#.r configure -drawbboxes t -set view [.r add group $top -tags controls] - -# -# Create the model -# -set model [.r add group $view] -set mp [.r add bezier $model "50 -150 100 -50 270 -130 220 -200 200 -180 180 -300 140 -160 70 -300" \ - -linecolor yellow -fillcolor tan -fillpattern AlphaStipple8 \ - -tags "bezier" -linewidth $lw] -#.r add rectangle $model "50 -150 100 -50" -set bbox [.r transform $model [.r bbox $mp]] -set x [expr ([lindex $bbox 2] + [lindex $bbox 0]) / 2] -set y [expr [lindex $bbox 1] + 5] -.r add text $model -text "CapRound" -color blue -alignment center -anchor s -tags "title" \ - -position "$x $y" - -# -# Now clone for each variation on the polygon -# -set col 0 -set row 0 -foreach current $show { - foreach {cap filled border relief title} $current { - set grp [.r clone $model] - .r translate $grp [expr $col * 240] [expr $row * (-290 - (2 * $lw))] - .r itemconfigure [.r find withtag "bezier" $grp] \ - -capstyle $cap -filled $filled \ - -linewidth [expr $border ? $lw : 0] \ - -relief $relief -linecolor [expr $relief == flat ? yellow : tan] - .r itemconfigure [.r find withtag "title" $grp] -text $title - incr col - if {$col >= 4} { - set col 0 - incr row - } - } -} - -# -# Suppress the model -# -.r remove $model - - -# -# Some optional graphic features -set closed 0 -#set smooth 0 -set arrows none - -proc toggle_arrows { } { - global arrows arrow - if {$arrows == "none"} { - set arrows first - set f $arrow - set l "" - } elseif {$arrows == "first"} { - set arrows last - set f "" - set l $arrow - } elseif {$arrows == "last"} { - set arrows both - set f $arrow - set l $arrow - } elseif {$arrows == "both"} { - set arrows none - set f "" - set l "" - } - .r itemconfigure bezier -firstend $f -lastend $l -} - - -proc toggle_closed { } { - global closed - set closed [expr ! $closed] - foreach curve [.r find withtag "bezier"] { - if {$closed} { - .r coords $curve add [.r coords $curve 0] - } { - .r coords $curve remove -1 - } - } - -} - -focus .r - -bind .r "" toggle_arrows -bind .r "" toggle_closed - -bind .r "" {set it [.r find closest %x %y]; puts "$it [.r verticeat $it %x %y]"} -bind .r "" {break} - -source "controls.tcl" diff --git a/sandbox/testbitmaps.tcl b/sandbox/testbitmaps.tcl deleted file mode 100644 index 27a519b..0000000 --- a/sandbox/testbitmaps.tcl +++ /dev/null @@ -1,86 +0,0 @@ -#!/usr/local/bin/wish -f - -lappend auto_path .. -package require Tkzinc -package require Img - -set r [zinc .r -render 1 -backcolor gray -relief sunken] -set top 1 -pack .r -expand t -fill both -.r configure -width 500 -height 800 - -set r [.r add rectangle $top "30 50 80 100" -filled t -fillpattern AlphaStipple0 -linewidth 1] -.r translate $r -55 -75 -.r rotate $r 45 -.r translate $r 55 75 - -.r add text $top -position "50 110" -text "0" -.r add rectangle $top "100 50 150 100" -filled t -fillpattern AlphaStipple1 -.r add text $top -position "120 110" -text "1" -.r add rectangle $top "170 50 220 100" -filled t -fillpattern AlphaStipple2 -.r add text $top -position "190 110" -text "2" -.r add rectangle $top "240 50 290 100" -filled t -fillpattern AlphaStipple3 -.r add text $top -position "260 110" -text "3" -.r add rectangle $top "310 50 360 100" -filled t -fillpattern AlphaStipple4 -.r add text $top -position "330 110" -text "4" -.r add rectangle $top "380 50 430 100" -filled t -fillpattern AlphaStipple5 -.r add text $top -position "400 110" -text "5" - -.r add rectangle $top "30 150 80 200" -filled t -fillpattern AlphaStipple6 -.r add text $top -position "50 210" -text "6" -.r add rectangle $top "100 150 150 200" -filled t -fillpattern AlphaStipple7 -.r add text $top -position "120 210" -text "7" -.r add rectangle $top "170 150 220 200" -filled t -fillpattern AlphaStipple8 -.r add text $top -position "190 210" -text "8" -.r add rectangle $top "240 150 290 200" -filled t -fillpattern AlphaStipple9 -.r add text $top -position "260 210" -text "9" -.r add rectangle $top "310 150 360 200" -filled t -fillpattern AlphaStipple10 -.r add text $top -position "330 210" -text "10" -.r add rectangle $top "380 150 430 200" -filled t -fillpattern AlphaStipple11 -.r add text $top -position "400 210" -text "11" - -.r add rectangle $top "100 250 150 300" -filled t -fillpattern AlphaStipple12 -.r add text $top -position "120 310" -text "12" -.r add rectangle $top "170 250 220 300" -filled t -fillpattern AlphaStipple13 -.r add text $top -position "190 310" -text "13" -.r add rectangle $top "240 250 290 300" -filled t -fillpattern AlphaStipple14 -.r add text $top -position "260 310" -text "14" -.r add rectangle $top "310 250 360 300" -filled t -fillpattern AlphaStipple15 -.r add text $top -position "330 310" -text "15" - -.r add text $top -position "180 360" -text "AlphaStipple" \ - -font "-*-lucida-bold-r-normal-*-14-*-*-*-*-*-*-*" - -for {set i 0} {$i < 22} {incr i} { - set num [expr $i + 1] - .r add waypoint $top 0 \ - -position "[expr 40 + ($i % 8)*60] [expr 420 + ($i / 8)*45]" \ - -symbol "AtcSymbol$num" - .r add text $top \ - -position "[expr 36 + ($i % 8)*60] [expr 430 + ($i / 8)*45]" \ - -text "$num" \ - -font "-*-helvetica-medium-r-*-*-*-120-*-*-*-*-*-*" -} - -.r add text $top -position "180 560" -text "AtcSymbol" \ - -font "-*-lucida-bold-r-normal-*-14-*-*-*-*-*-*-*" - - -set im [image create bitmap toto -background "red" -file fvwm.xbm] -set icim [.r add icon 1 -image $im -position {0 0}] -.r rotate $icim 20 -.r scale $icim 1.2 1.2 -.r translate $icim 50 320 -#.r add icon 1 -image $im -position {300 10} -#.r add rectangle 1 {10 10 100 100} -tile $im -filled 1 -#$im configure -background red - -set icbit [.r add icon 1 -image @fvwm.xbm -position {100 400}] - -#.r bind $icbit ".r itemconfigure $icbit -color red; \ -# $im configure -file fvwm.xbm -foreground black" -#.r bind $icbit ".r itemconfigure $icbit -color black; \ -# $im configure -file trash.xbm -foreground red " - -#.r bind $icim "$im configure -background black" -#.r bind $icim "$im configure -background red" diff --git a/sandbox/testicon.tcl b/sandbox/testicon.tcl deleted file mode 100644 index fd8ba39..0000000 --- a/sandbox/testicon.tcl +++ /dev/null @@ -1,102 +0,0 @@ -#!/usr/local/bin/wish -f - -load ../tkzinc3.2.so -package require Img - -set top 1 - -image create photo penguin -file xpenguin.png -image create photo bouton -file bouton.xpm -image create photo boutond -file bouton-down.xpm -set mask "fvwm.xbm" - -set r [zinc .r -backcolor gray -relief sunken -render 1 -borderwidth 20] -pack .r -expand t -fill both -.r configure -width 800 -height 500 -#.r configure -drawbboxes t -.r scale $top 1 -1 -set view [.r add group $top -tags "controls"] - -proc maskicon {x y group mask color anchor} { - .r add icon $group -mask "@$mask" -position "$x $y" -anchor $anchor -color $color - .r add rectangle $group [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red -} - -proc imageicon {x y group image anchor} { - .r add icon $group -image $image -position "$x $y" -anchor $anchor - .r add rectangle $group [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red -} - -set x 50.0 -set y -100.0 -maskicon $x $y $view $mask yellow sw -set x [expr $x + 100.0] -maskicon $x $y $view $mask pink s -set x [expr $x + 100.0] -maskicon $x $y $view $mask violet se -set x 50 -set y -150 -maskicon $x $y $view $mask lightblue w -set x [expr $x + 100.0] -maskicon $x $y $view $mask blue center -set x [expr $x + 100.0] -maskicon $x $y $view $mask darkblue e -set x 50.0 -set y -200.0 -maskicon $x $y $view $mask violet nw -set x [expr $x + 100.0] -maskicon $x $y $view $mask pink n -set x [expr $x + 100.0] -maskicon $x $y $view $mask yellow ne -set x2 500.0 -set y2 -300.0 -imageicon $x2 $y2 $view penguin center - -.r add icon $view -image bouton -position "$x2 $y2" -anchor center -.r add icon $view -image boutond -position [list [expr $x2 + 50] $y2] -anchor center -.r add text $view -text essai -position "$x2 $y2" - -# -# Clip -# -puts "crée les clips" -set clip [.r add rectangle $view "50 -10 600 -300" -filled t \ - -linewidth 0 -fillcolor darkgray] -#.r rotate $clip [expr 3.14159 / 4]; #bug le rectangle forme un bonnet -# d'ane sous certains angles. -.r lower $clip -.r itemconfigure $view -clip $clip - -.r addtag test withtype icon -.r bind test "" "testpress %x %y" -.r bind test "" testrelease - -proc testpress {lx ly} { - global testx testy - set testx $lx - set testy $ly - .r bind test "" "testmotion %x %y" -} - -proc testmotion {lx ly} { - global testx testy - set it [.r find withtag test] - if {$it != ""} { - set it [.r group [lindex $it 0]] - } - set res [.r transform $it "$lx $ly $testx $testy"] - set nx [lindex $res 0] - set ny [lindex $res 1] - set ox [lindex $res 2] - set oy [lindex $res 3] - .r translate current [expr $nx - $ox] [expr $ny - $oy] - set testx $lx - set testy $ly -} -proc testrelease {} { - .r bind test "" "" -} - -source controls.tcl diff --git a/sandbox/testplug.pl b/sandbox/testplug.pl deleted file mode 100644 index 418c91a..0000000 --- a/sandbox/testplug.pl +++ /dev/null @@ -1,51 +0,0 @@ -#!/usr/bin/perl - -use Tk; - -$mw = MainWindow->new(); - -$zinc = $mw->Zinc(-backcolor => 'gray', - -relief => 'sunken', - -width => 800, - -height => 500)->pack(-expand => 1, - -fill => 'both'); -$top = 1; -#$ent = $zinc->Entry(); -#$entryitem = $zinc->add('window', $top, -# -window => $ent, -# -position => [100, 100]); -$dcontainer = $zinc->Frame(-container => 1); -$did = $dcontainer->id(); -$vcontainer = $zinc->Frame(-container => 1); -$vid = $vcontainer->id(); -#print "container id is $id\n"; - -$dlabel = $zinc->add('text', $top, - -text => "Digistrips", - -position => [150, 30]); -$zinc->bind($dlabel, '<1>', sub { $zinc->itemconfigure($vlabel, -color => 'black'); - $zinc->itemconfigure($dlabel, -color => 'red'); - $zinc->itemconfigure($vcontitem, -visible => 0); - $zinc->itemconfigure($dcontitem, -visible => 1); }); -$vlabel = $zinc->add('text', $top, - -text => "Virtuosi", - -position => [250, 30]); -$zinc->bind($vlabel, '<1>', sub { $zinc->itemconfigure($dlabel, -color => 'black'); - $zinc->itemconfigure($vlabel, -color => 'red'); - $zinc->itemconfigure($dcontitem, -visible => 0); - $zinc->itemconfigure($vcontitem, -visible => 1); }); -$dcontitem = $zinc->add('window', $top, - -window => $dcontainer, - -position => [50, 75], - -visible => 0); -$vcontitem = $zinc->add('window', $top, - -window => $vcontainer, - -position => [50, 75], - -visible => 0); - -$mw->update(); - -system("digistripsIII -stan --use $did -style standalone-1024x768 &"); -system("virtuosi -g 1024x768 -use $vid &"); - -MainLoop(); diff --git a/sandbox/testpoly.tcl b/sandbox/testpoly.tcl deleted file mode 100644 index 2a16288..0000000 --- a/sandbox/testpoly.tcl +++ /dev/null @@ -1,157 +0,0 @@ -#!/usr/local/bin/wish -f - -lappend auto_path .. -package require Tkzinc -package require Img - -set top 1 -set lw 8 -set marker AtcSymbol9 -set arrow "8 10 6" - - -# -# Cap Join Filled Border Relief Title -# -set show {\ - {round round f 1 flat JoinRound}\ - {round bevel f 1 flat JoinBevel}\ - {round miter f 1 flat JoinMiter}\ - {butt round f 1 flat CapButt}\ - {projecting round f 1 flat CapProjecting}\ - {round round f 1 sunken Sunken}\ - {round round f 1 raised Raised}\ - {round round f 1 groove Groove}\ - {round round f 1 ridge Ridge}\ - {round round t 1 sunken FilledSunken}\ - {round round t 1 raised FilledRaised}\ - {round round t 1 groove FilledGroove}\ - {round round t 1 ridge FilledRidge}\ - {round round f 0 flat Marker}\ - {round round t 0 flat Fill}\ - {round round t 1 flat FillBorder}} - -image create photo logo -file logo.gif -#image create photo papier -file /usr/share/toccata/images/dgtexture-dragstrip.xpm - -set r [zinc .r -backcolor gray -relief sunken -render 0] -pack .r -expand t -fill both -.r configure -width 1024 -height 800 -.r scale $top 1 -1 -#.r configure -drawbboxes t -set view [.r add group $top -tags controls] - -# -# Create the model -# -set model [.r add group $view] -set mp [.r add curve $model "50 -150 100 -50 270 -130 220 -200 200 -180 180 -300 140 -160 70 -300" \ - -linecolor yellow -fillcolor tan -fillpattern AlphaStipple8 \ - -markercolor red -tags "poly" -linewidth $lw] -.r add rectangle $model "50 -150 100 -50" -set bbox [.r transform $model [.r bbox $mp]] -set x [expr ([lindex $bbox 2] + [lindex $bbox 0]) / 2] -set y [expr [lindex $bbox 1] + 5] -.r add text $model -text "CapRound" -color blue -alignment center -anchor s -tags "title" \ - -position "$x $y" - -# -# Now clone for each variation on the polygon -# -proc linecol { relief } { - if {[string compare $relief flat]} { - return yellow - } else { - return tan - } -} - -set col 0 -set row 0 -foreach current $show { - foreach {cap join filled border relief title} $current { - set grp [.r clone $model] - .r translate $grp [expr $col * 240] [expr $row * (-290 - (2 * $lw))] - .r itemconfigure [.r find withtag "$grp*poly"] \ - -capstyle $cap -joinstyle $join -filled $filled \ - -linewidth [expr $border ? $lw : 0] -relief $relief \ - -linecolor [linecol $relief] - .r itemconfigure [.r find withtag "$grp*title"] -text $title - incr col - if {$col >= 4} { - set col 0 - incr row - } - } -} - -# -# Suppress the model -# -.r remove $model - - -# -# Some optional graphic features -set closed 0 -set marks 0 -#set smooth 0 -set arrows none - -proc toggle_arrows { } { - global arrows arrow - if {$arrows == "none"} { - set arrows first - set f $arrow - set l "" - } elseif {$arrows == "first"} { - set arrows last - set f "" - set l $arrow - } elseif {$arrows == "last"} { - set arrows both - set f $arrow - set l $arrow - } elseif {$arrows == "both"} { - set arrows none - set f "" - set l "" - } - .r itemconfigure poly -firstend $f -lastend $l -} - -proc toggle_marks { } { - global marks marker - set marks [expr ! $marks] - if {$marks} { - .r itemconfigure poly -marker $marker - } { - .r itemconfigure poly -marker "" - } -} - -#proc toggle_smooth { } { -# global smooth -# set smooth [expr ! $smooth] -# .r itemconfigure poly -smoothed $smooth -#} - -proc toggle_closed { } { - global closed - set closed [expr ! $closed] - foreach curve [.r find withtag "poly"] { - .r itemconfigure $curve -closed $closed - } - -} - -focus .r - -bind .r "" toggle_arrows -bind .r "" toggle_closed -bind .r "" toggle_marks - -bind .r "" {set it [.r find closest %x %y]; puts "$it [.r verticeat $it %x %y]"} -bind .r "" {break} - -source "controls.tcl" diff --git a/sandbox/testrect.pl b/sandbox/testrect.pl deleted file mode 100644 index 8a4d399..0000000 --- a/sandbox/testrect.pl +++ /dev/null @@ -1,99 +0,0 @@ -#!/usr/bin/perl -w - -use Tk; -use Tk::Zinc; - -use Controls; - -$mw = MainWindow->new(); - - -################################################### -# creation zinc -################################################### -$top = 1; -$zinc_width = 800; -$zinc_height = 500; - -$zinc = $mw->Zinc(-backcolor => 'gray65', -relief => 'sunken'); -$zinc->pack(-expand => 1, -fill => 'both'); -$zinc->configure(-width => $zinc_width, -height => $zinc_height); - -#$zinc->configure(-drawbboxes => 1); - -#print "cells ", $zinc->cells(), " visual ", $zinc->visual(), " ", $zinc->visualsavailable(), "\n"; - -$zinc->scale($top, 1, -1); -$view = $zinc->add('group', $top, -tags => ["controls"]); -$zinc->translate($view, 300, -200); -$view2 = $zinc->add('group', $top); -$zinc->translate($view2, 100, -50); - - -#$rect0 = $zinc->add('rectangle', $view [100, -105, 200, -305], -# -filled => t, -# -fillcolor => "white|cadetblue3"); - -$color1 = 'darkslateblue'; -$color2 = '#f0ffff'; -$gangle = 0; -$shades = 8; -$rect1 = $zinc->add('rectangle', $view, [-50, 100, 50, -100], - -filled => 1, - -relief => 'flat', - -linewidth => 1, - -fillpattern => 'AlphaStipple7', - -fillcolor => "$color1|$color2/$gangle%$shades"); -# -# Mire -$zinc->add('curve', $view, [-10, 0, 10, 0], - -linecolor => 'red'); -$zinc->add('curve', $view, [0, -10, 0, 10], - -linecolor => 'red'); - -$handle = $zinc->add('arc', $view, [-3, -106, 3, -112], - -filled => 1, - -fillcolor => 'red'); -$zinc->bind($handle, '', \&adjustcontrol); - -sub adjustcontrol { - my $ev = $zinc->XEvent(); - my $x; - my $y; - my ($xo, $yo, $xc, $yc) = $zinc->coords($rect1); - - ($x, $y) = $zinc->transform($view, [$ev->x, 0]); - if ($x < $xo) { - $x = $xo; - } - elsif ($x > $xc) { - $x = $xc; - } - $zinc->coords($handle, [$x - 3, $yc-6, $x + 3, $yc-12]); - $x = ($x - $xo)*100/($xc-$xo); - $zinc->itemconfigure($rect1, - -fillcolor => "$color1 0 $x|$color2/$gangle%$shades"); -} - -# -# 72 61 139 = DarkSlateBlue -# -# 240 255 255 = azure -# -#set rect2 [.r add rectangle $view "202 -320 302 -350" -filled t -fillcolor darkgray -linewidth 2] - -#set rect3 [.r add rectangle $view "250 -100 350 -300" -filled t -relief raised -linewidth 4 -fillcolor "white|cadetblue3" -linecolor white] - -#set rect4 [.r add rectangle $view2 "0 0 101 -81" -linewidth 2 -linecolor darkgray -filled t] -#.r itemconfigure $rect4 -fillcolor "white|darkslateblue" - -#set rect5 [.r add rectangle $view2 "0 0 101 -81" -linewidth 2 -linecolor blue -filled t -fillcolor blue -relief sunken] -#.r translate $rect5 0 -90 - - -new Controls($zinc); - -MainLoop(); - - -1; diff --git a/sandbox/testrelief.pl b/sandbox/testrelief.pl deleted file mode 100644 index 79c9a31..0000000 --- a/sandbox/testrelief.pl +++ /dev/null @@ -1,73 +0,0 @@ -#!/usr/bin/perl -w - -use Tk; -use Tk::Zinc; -use Controls; - -$top = 1; -$lw = 8; - -$mw = MainWindow->new(); -$zinc = $mw->Zinc(-backcolor => 'gray', - -relief => 'sunken', - -lightangle => 120, - -render => 1); -$zinc->pack(-expand => 1, - -fill => 'both'); -$zinc->configure(-width => 1024, - -height => 800); -$zinc->scale($top, 1, -1); - -$view = $zinc->add('group', $top, -tags => 'controls'); - -sub polypoints { - ($ox, $oy, $rad, $n, $startangle) = @_; - - $step = 2 * 3.14159 / $n; - $startangle = $startangle*3.14159/180; - $coords = []; - for ($i = 0; $i < $n; $i++) { - $x = $ox + ($rad * cos($i * $step + $startangle)); - $y = $oy + ($rad * sin($i * $step + $startangle)); - push(@{$coords}, $x, $y); - } - push(@{$coords}, $coords->[0], $coords->[1]); - return $coords -} - -$zinc->add('curve', $view, polypoints(200, -200, 100, 40, 0), - -relief => 'raised', - -linewidth => $lw, - -smoothrelief => 1, - -fillcolor => 'lightblue', - -linecolor => 'lightblue', - -filled => 1); - -$zinc->add('curve', $view, polypoints(450, -200, 100, 40, 0), - -relief => 'raised', - -linewidth => $lw, - -smoothrelief => 1, - -fillcolor => 'tan', - -linecolor => 'tan', - -filled => 1); - -$zinc->add('curve', $view, polypoints(700, -200, 100, 40, 0), - -relief => 'sunken', - -linewidth => $lw, - -smoothrelief => 1, - -fillcolor => 'tan', - -linecolor => 'tan', - -closed => 1, - -filled => 1); - -$zinc->add('curve', $view, polypoints(200, -450, 100, 7, -45), - -relief => 'sunken', - -linewidth => $lw, - -fillcolor => 'tan', - -linecolor => 'tan', - -filled => 1); - - -new Controls($zinc); -MainLoop(); - diff --git a/sandbox/testrelief.tcl b/sandbox/testrelief.tcl deleted file mode 100644 index e75cc71..0000000 --- a/sandbox/testrelief.tcl +++ /dev/null @@ -1,45 +0,0 @@ -#!/usr/local/bin/wish -f - -load ../tkzinc3.2.so - -set top 1 -set lw 8 - -set r [zinc .r -backcolor gray -relief sunken -lightangle 120 -render 0] -pack .r -expand t -fill both -.r configure -width 1024 -height 800 -.r scale $top 1 -1 - -set view [.r add group $top -tags controls] - -proc polypoints { ox oy rad n startangle } { - set step [expr 2 * 3.14159 / $n] - set startangle [expr $startangle*3.14159/180] - set coords "" - for {set i 0} {$i < $n} {incr i} { - set x [expr $ox + ($rad * cos($i * $step + $startangle))]; - set y [expr $oy + ($rad * sin($i * $step + $startangle))]; - lappend coords $x $y; - } - lappend coords [lindex $coords 0] [lindex $coords 1] - return $coords -} - -set poly [ .r add curve $view [polypoints 200 -200 100 40 0] \ - -relief raised -linewidth $lw -smoothrelief 1 \ - -fillcolor lightblue -linecolor lightblue -filled t] - -set poly [ .r add curve $view [polypoints 450 -200 100 40 0] \ - -relief raised -linewidth $lw \ - -fillcolor tan -linecolor tan -filled t] - -set poly [ .r add curve $view [polypoints 700 -200 100 40 0] \ - -relief sunken -linewidth $lw \ - -fillcolor tan -linecolor tan -filled t] - -set poly [ .r add curve $view [polypoints 200 -450 100 4 -45] \ - -relief sunken -linewidth $lw \ - -fillcolor tan -linecolor tan -filled t] - - -source "controls.tcl" diff --git a/sandbox/testshape.pl b/sandbox/testshape.pl deleted file mode 100644 index 5897912..0000000 --- a/sandbox/testshape.pl +++ /dev/null @@ -1,132 +0,0 @@ -#!/usr/bin/perl -w - -use Tk; -use Tk::Zinc; -use Controls; - -$mw = MainWindow->new(); - -$top = 1; -$zinc = $mw->Zinc(-render => 1, - -borderwidth => 0, -# -fullreshape => 0, - -relief => 'sunken'); -$zinc->pack(-expand => 1, -fill => 'both'); -$zinc->configure(-width => 500, -height => 500); - -$zinc->gname('white:40 0 60|black 50|white 100(0 0', 'oeil'); -$zinc->gname('white:0 0 10|black:100 100/0', 'oeil2'); -$zinc->gname('white:100|black:100(-35 -25', 'boule'); -$zinc->gname('white:100|black:100(-15 -100', 'arrondi'); -$zinc->gname('white:100|black:100/45', 'cyl'); -$zinc->gname('white|black[50 0', 'path'); - -# $arc = $zinc->add('arc', $top, [50, 50, 200, 100], -# -visible => 0); -#$zinc->itemconfigure($top, -clip => $arc); - -$view = $zinc->add('group', $top, -tags => "controls"); -# $cv = $zinc->add('curve', $view, [50, 50, 100, 150, 270, 70, -# 220, 0, 200, 20, 180, 100, -# 140, 40, 70, 100], -# -visible => 1, -# -closed => 1, -# -filled => 1); - -$g1 = $zinc->add('group', $view); -$zinc->translate($g1, 100, 300); -$rect = $zinc->add('rectangle', $g1, [-40,-50, 40,50], - -filled => 1, - -fillcolor => 'path' - ); -$g2 = $zinc->add('group', $view); -$zinc->translate($g2, 200, 300); -$arc = $zinc->add('arc', $g2, [0,0, 100,100], - -filled => 1, - -linecolor => 'white', - -fillcolor => 'boule', - -startangle => 120, - -extent => 120, - -closed => 1, - -pieslice => 1, -# -fillcolor => 'tan' - ); -$arc2 = $zinc->add('arc', $view, [90,0, 160,50], - -visible => 0, - -linewidth => 0, - -filled => 1, - -fillcolor => 'brown'); -$g3 = $zinc->add('group', $view); -$zinc->translate($g3, 300, 300); -$cv3 = $zinc->add('curve', $g3, -# [[-50, -40], [0, 0], [-50, 40], [50, 40], [50, -40]], - [-50, -40, 0, 0, -50, 40, 50, 40, 50, -40], - -visible => 0, - -filled => 1, - -fillcolor => "#ffffff:100 0 28|#66848c:100 80|#7192aa:100 100/270" -# -fillcolor => 'cyl' -); - -# $rect = $zinc->add('rectangle', $view, [200,230, 220,250], -# -visible => 1, -# -linewidth => 2, -# -relief => 'sunken', -# -filled => 1, -# -linecolor => 'white', -# -fillcolor => 'tan'); -$cv2 = $zinc->add('curve', $view, [], - -visible => 1, - -linewidth => 2, - -linecolor => 'white', - -fillcolor => 'tan', - -fillrule => 'positive', - -relief => 'sunken', - -closed => 1, - -filled => 1); -$text = $zinc->add('text', $view, - -visible => 1, - -text => 'Un Texte ICI°°°°°', - -position => [200, 100], - -color => '#008000'); -$zinc->contour($cv2, 'add', 1, [[20, 20], [20, 100, 'c'], [120, 100], [120, 20]]); -$zinc->contour($cv2, 'add', -1, [40, 40, 80, 40, 80, 80, 40, 80]); -$zinc->contour($cv2, 'add', 1, [60, 50, 60, 60, 70, 60, 70, 50]); -$zinc->contour($cv2, 'add', -1, [90, 70, 150, 70, 150, 150, 90, 150]); -$zinc->contour($cv2, 'add', 1, [200, 200, 200, 220, 220, 220, 220, 200]); -$zinc->contour($cv2, 'add', -1, [100, 10, 180, 10, 180, 60, 100, 60]); - -$zinc->contour($cv2, 'add', 1, $arc2); -$zinc->contour($cv2, 'add', 1, $text); - -# $rect2 = $zinc->add('rectangle', $view, [40,81, 80,130], -# -visible => 1, -# -linewidth => 1, -# -relief => 'sunken', -# -filled => 1, -# -linecolor => 'white', -# -fillcolor => 'tan'); - -new Controls($zinc); - -$zinc->Tk::bind('', sub {print "hop\n", $zinc->contour($cv2, 'remove', 1);}); -$zinc->Tk::bind('', sub {my ($x,$y,$c) = $zinc->coords($cv2, 0, 1); - if ($c eq 'c') { - $zinc->coords($cv2, 0, 1, [[20, 100]]); - } - else { - $zinc->coords($cv2, 0, 1, [[20, 100, 'c']]); - }}); -$zinc->Tk::bind('<1>', sub { - my $ev = $zinc->XEvent(); - my $it = $zinc->find('closest', $ev->x, $ev->y); - print "Closest: $it\n"; -# my @t = $zinc->vertexat($it, $ev->x, $ev->y); -# print "VertexAt: ", join(', ', @t), "\n"; - $zinc->bind($cv2, '<1>', sub { print "zou\n";}); - $zinc->coords($cv2, 0, [[100,0]]); - print $zinc->bind($cv2, '<1>'), "\n"; - }); - -$zinc->focusFollowsMouse(); - -MainLoop(); diff --git a/sandbox/testshape.tcl b/sandbox/testshape.tcl deleted file mode 100644 index 2ed5327..0000000 --- a/sandbox/testshape.tcl +++ /dev/null @@ -1,18 +0,0 @@ -#!/usr/local/bin/wish -f - -load ../tkzinc3.2.so - -set top 1 - -set r [zinc .r -render 0 -borderwidth 0 -fullreshape 0 -relief sunken] -pack $r -expand t -fill both -$r configure -width 500 -height 500 - -set arc [.r add arc $top "50 50 200 150" -visible 1 -closed 0 -filled 0 -fillcolor white -extent 200 -pieslice 0] - -set cv [.r add curve $top "50 50 100 150 270 70 220 0 200 20 180 -100 140 40 70 -100" \ - -visible 0] - -.r rotate $arc [expr 3.14/10] 125 100 - -.r itemconfigure $top -clip $cv diff --git a/sandbox/testtext.tcl b/sandbox/testtext.tcl deleted file mode 100644 index 44d3d8f..0000000 --- a/sandbox/testtext.tcl +++ /dev/null @@ -1,138 +0,0 @@ -lappend auto_path .. - -package require Tkzinc -package require Img - -set mask "/usr/X11R6/include/X11/bitmaps/fvwm.xbm" - -set r [zinc .r -backcolor gray -relief sunken \ - -insertbackground red -insertwidth 10 -render 0] -pack .r -expand t -fill both -.r configure -width 800 -height 500 -# .r configure -drawbboxes t -set top [.r add group 1] -.r addtag controls withtag $top - -.r add rectangle $top "-50 0 +50 1" -composescale 0 -.r add rectangle $top "0 -50 1 +50" -composescale 0 - -set x 50.0 -set y 100.0 -.r add text $top -text "Ancrage Sud Ouest" -position "$x $y" -anchor sw \ - -color yellow -.r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red - -set x [expr $x + 200.0] -.r add text $top -text "Ancrage Sud" -position "$x $y" -anchor s -color pink -.r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red - -set x [expr $x + 200.0] -.r add text $top -text "Ancrage Sud Est" -position "$x $y" -anchor se \ - -color violet -overstriked y -.r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red - -set x 50 -set y 150 -.r add text $top -text "Ancrage Ouest" -position "$x $y" -anchor w -color lightblue -.r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red - -set x [expr $x + 200.0] -.r add text $top -text "Ancrage Central" -position "$x $y" -anchor center -color blue -.r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red - -set x [expr $x + 200.0] -.r add text $top -text "Ancrage Est" -position "$x $y" -anchor e -color darkblue -.r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red - -set x 50.0 -set y 200.0 -.r add text $top -text "Ancrage Nord Ouest" -position "$x $y" -anchor nw \ - -color violet -underlined y -.r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red - -set x [expr $x + 200.0] -.r add text $top -text "Ancrage Nord" -position "$x $y" -anchor n -color pink -.r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red - -set x [expr $x + 200.0] -.r add text $top -text "Ancrage Nord Est" -position "$x $y" -anchor ne -color yellow -.r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red - -set x 150 -set y 300 -.r add text $top -text "Ce texte tient sur plusieurs lignes.\nLes alignements :\n- à gauche\n- à droite\n- au centre\nsont également mis en évidence.\n" -position "$x $y" -anchor center -.r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red - -set x 400 -set y 300 -set anim [.r add text $top -text "Ce texte tient sur plusieurs lignes.\nLes alignements :\n- à gauche\n- à droite\n- au centre\nsont également mis en évidence.\nLe texte central montre l'utilisation\nd'un espacement des lignes programmable." -position "$x $y" -anchor center -alignment center -spacing -5 -font {times 14 bold italic}] -.r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red - -set x 650 -set y 300 -.r add text $top -text "Ce texte tient sur plusieurs lignes.\nLes alignements :\n- à gauche\n- à droite\n- au centre\nsont également mis en évidence.\n" -position "$x $y" -anchor center -alignment right -.r add rectangle $top [list [expr $x - 3.0] [expr $y - 3.0] \ - [expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red - - -.r addtag text withtype text -.r bind text "<1>" {textB1press %x %y} -.r bind text "" {textB1move %x %y} -.r bind text "" {textB1move %x %y} -.r bind text "" {.r select adjust current @%x,%y} -.r bind text "" {.r insert [.r focus] insert %A} -.r bind text "" {.r insert [.r focus] insert %A} -.r bind text "" {.r insert [.r focus] insert \n} -.r bind text "" textBs -.r bind text "" textBs -.r bind text "" textBs -.r bind text "" {.r dchars text sel.first sel.last} -.r bind text "" {.r insert [.r focus] insert [selection get]} - -proc textB1press {x y} { - .r cursor current "@$x,$y" - .r focus current - focus .r - .r select from current "@$x,$y" -} - -proc textB1move {x y} { - .r select to current "@$x,$y" -} - -proc textBs { } { - set item [.r focus] - set i [expr [.r index $item insert] - 1] - if { $i >= 0 } { - .r dchars $item $i - } -} - -# -# Add controls to the main group -# -source controls.tcl - -# -# Line spacing animation (crude). -# -if {0} { - set i 0 - while {1} { - update - after 200 - .r itemconfigure $anim -spacing [expr ($i % 20) - 5] - incr i - } -} diff --git a/sandbox/testwind.tcl b/sandbox/testwind.tcl deleted file mode 100644 index 5ff7f76..0000000 --- a/sandbox/testwind.tcl +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/local/bin/wish -f - -load ../tkzinc3.2.so - -set top 1 - -set r [zinc .r -backcolor gray -relief sunken] -pack .r -expand t -fill both -.r configure -width 800 -height 500 - -.r addtag controls withtag $top - -set ent [entry .r.entry] -set wind [.r add window $top -window $ent -position "100 100"] - -set container [frame .r.cont -container t] -set id [winfo id $container] -puts "container id is $id\n" -set cont [.r add window $top -window $container -position "200 200"] diff --git a/sandbox/testzinc.pl b/sandbox/testzinc.pl deleted file mode 100644 index f25f9de..0000000 --- a/sandbox/testzinc.pl +++ /dev/null @@ -1,503 +0,0 @@ -#!/usr/bin/perl -w - - -use Tk; -use Tk::Zinc; -use Tk::Photo; -use Tk::ZincText; -#use ZincText; -use Controls; - -$map_path = "/usr/share/toccata/maps"; - -$mw = MainWindow->new(); -$logo = $mw->Photo(-file => "logo.gif"); - - -################################################### -# creation zinc -################################################### -$top = 1; -$scale = 1.0; -$center_x = 0.0; -$center_y = 0.0; -$zinc_width = 800; -$zinc_height = 500; -$delay = 2000; -$rate = 0.3; -%tracks = (); - -$zinc = $mw->Zinc(-render => 2, -backcolor => 'gray65', -relief => 'sunken'); -$zinc->pack(-expand => 1, -fill => 'both'); -$zinc->configure(-width => $zinc_width, -height => $zinc_height); -#$radar = $top; -$radar = $zinc->add('group', $radar, -tags => ['controls', 'radar']); -$zinc->configure(-overlapmanager => $radar); - -new ZincText($zinc); -################################################### -# Création fonctions de contrôle à la souris -################################################### -new Controls($zinc); - -################################################### -# creation panneau controle -################################################### -$rc = $mw->Frame()->pack(); -$rc->Button(-text => 'Up', - -command => sub { $center_y -= 30.0; - update_transform($zinc); })->grid(-row => 0, - -column => 2, - -sticky, 'ew'); -$rc->Button(-text => 'Down', - -command => sub { $center_y += 30.0; - update_transform($zinc); })->grid(-row => 2, - -column => 2, - -sticky, 'ew'); -$rc->Button(-text => 'Left', - -command => sub { $center_x += 30.0; - update_transform($zinc); })->grid(-row => 1, - -column => 1); -$rc->Button(-text => 'Right', - -command => sub { $center_x -= 30.0; - update_transform($zinc); })->grid(-row => 1, - -column => 3); -$rc->Button(-text => 'Expand', - -command => sub { $scale *= 1.1; - update_transform($zinc); })->grid(-row => 1, - -column => 4); -$rc->Button(-text => 'Shrink', - -command => sub { $scale *= 0.9; - update_transform($zinc); })->grid(-row => 1, - -column => 0); -$rc->Button(-text => 'Reset', - -command => sub { $scale = 1.0; - $center_x = $center_y = 0.0; - update_transform($zinc); })->grid(-row => 1, - -column => 2, - -sticky, 'ew'); -$rc->Button(-text => 'Quit', - -command => \&exit)->grid(-row => 3, - -column => 2); - - -################################################### -# Code de reconfiguration lors d'un -# redimensionnement. -################################################### -$zinc->Tk::bind('', [\&resize]); - -sub resize { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - my $width = $ev->w; - my $height = $ev->h; - my $bw = $zinc->cget(-borderwidth); - $zinc_width = $width - 2*$bw; - $zinc_height = $height - 2*$bw; - update_transform($zinc); -} - -sub update_transform { - my ($zinc) = @_; - - $zinc->treset($top); - $zinc->translate($top, -$center_x, -$center_y); - $zinc->scale($top, $scale, $scale); - $zinc->scale($top, 1, -1); - $zinc->translate($top, $zinc_width/2, $zinc_height/2); -} - - -################################################### -# Creation de pistes. -################################################### -sub create_tracks { - my $i = 20; - my $j; - my $track; - my $x; - my $y; - my $w = $zinc_width / $scale; - my $h = $zinc_height / $scale; - my $d; - my $item; - - for ( ; $i > 0; $i--) { - $track = {}; - $track->{'item'} = $item = $zinc->add('track', $radar, 6); - $tracks{$item} = $track; - $track->{'x'} = rand($w) - $w/2 + $center_x; - $track->{'y'} = rand($h) - $h/2 + $center_y; - $d = (rand() > 0.5) ? 1 : -1; - $track->{'vx'} = (8.0 + rand(10.0)) * $d; -# $track->{'vx'} = 10; - $d = (rand() > 0.5) ? 1 : -1; - $track->{'vy'} = (8.0 + rand(10.0)) * $d; -# $track->{'vy'} = -10; - $zinc->itemconfigure($item, - -lastasfirst => 1, - -symbolcolor => 'red', - -position => [$track->{'x'}, $track->{'y'}], - -speedvector => [$track->{'vx'}, $track->{'vy'}], - -speedvectorsensitive => 1, - -speedvectorwidth => 2, - -speedvectormark => 1, - -speedvectorticks => 1, - -labeldistance => 30, - -markersize => 20, - -historycolor => 'gray30', - -filledhistory => 0, - -circlehistory => 1, - -labelformat => "x71x50+0+0 a0a0^0^0 a0a0^0>1 a0a0>2>1 a0a0>3>1 a0a0^0>2" - ); - $zinc->itemconfigure($item, 0, - -filled => 0, - -backcolor => 'gray60', -# -border => "contour", - -sensitive => 1 - ); - $zinc->itemconfigure($item, 1, - -filled => 1, - -backcolor => 'gray55', - -text => "AFR001"); - $zinc->itemconfigure($item, 2, - -filled => 0, - -backcolor => 'gray65', - -text => "360"); - $zinc->itemconfigure($item, 3, - -filled => 0, - -backcolor => 'gray65', - -text => "/"); - $zinc->itemconfigure($item, 4, - -filled => 0, - -backcolor => 'gray65', - -text => "410"); - $zinc->itemconfigure($item, 5, - -filled => 0, - -backcolor => 'gray65', - -text => "Balise"); - my $b_on = sub { #print_current($zinc); - $zinc->itemconfigure('current', $zinc->currentpart(), - -border => 'contour')}; - my $b_off = sub { #print_current($zinc); - $zinc->itemconfigure('current', $zinc->currentpart(), - -border => 'noborder')}; - my $tog_b = sub { my $current = $zinc->find('withtag', 'current'); - my $curpart = $zinc->currentpart(); - if ($curpart =~ '[0-9]+') { - my $on_off = $zinc->itemcget($current, $curpart, -sensitive); - $zinc->itemconfigure($current, $curpart, - -sensitive => !$on_off); - } - }; - for ($j = 0; $j < 6; $j++) { - $zinc->bind($item.":$j", '', $b_on); - $zinc->bind($item.":$j", '', $b_off); - $zinc->bind($item, '<1>', $tog_b); - $zinc->bind($item, '', sub {}); - } - $zinc->bind($item, '', - sub { #print_current($zinc); - $zinc->itemconfigure('current', - -historycolor => 'red', - -symbolcolor => 'red', - -markercolor => 'red', - -leaderwidth => 2, - -leadercolor => 'red', - -speedvectorwidth => 2, - -speedvectorcolor => 'red')}); - $zinc->bind($item, '', - sub { #print_current($zinc); - $zinc->itemconfigure('current', - -historycolor => 'black', - -symbolcolor => 'black', - -markercolor => 'black', - -leaderwidth => 1, - -leadercolor => 'black', - -speedvectorwidth => 1, - -speedvectorcolor => 'black')}); - $zinc->bind($item.':position', '<1>', [\&create_route]); - $zinc->bind($item.':position', '', sub { }); - $track->{'route'} = 0; - } -} - -create_tracks(); - -sub print_current { - my ($zinc) = @_; - my $current; - - $current = $zinc->find('withtag', 'current'); - print join(' ', $current), "\n"; -# print ref($zinc->itemcget($current, -position)) ? 'ref' : 'pas ref', "\n"; -# print 'tout '; -# for $attr ($zinc->itemconfigure($current)) { -# print (join(',', @$attr)); -# } -# print "\n\n"; -# print '-position ', join(',', $zinc->itemconfigure($current, -position)), "\n\n"; -} - -################################################### -# creation way point -################################################### -sub create_route { - my ($zinc) = @_; - my $wp; - my $connected; - my $x; - my $y; - my $i = 4; - my $track = $tracks{$zinc->find('withtag', 'current')}; - - if ($track->{'route'} == 0) { - $x = $track->{'x'} + 8.0 * $track->{'vx'}; - $y = $track->{'y'} + 8.0 * $track->{'vy'}; - $connected = $track->{'item'}; - for ( ; $i > 0; $i--) { - $wp = $zinc->add('waypoint', 'radar', 2, - -position => [$x, $y], - -connecteditem => $connected, - -connectioncolor => 'green', - -symbolcolor => 'green', - -labelformat => 'x20x18+0+0'); - $zinc->lower($wp, $connected); - $zinc->bind($wp.':0', '', - sub {$zinc->itemconfigure('current', 0, -border => 'contour')}); - $zinc->bind($wp.':position', '', - sub {$zinc->itemconfigure('current', -symbolcolor => 'red')}); - $zinc->bind($wp.':leader', '', - sub {$zinc->itemconfigure('current', -leadercolor => 'red')}); - $zinc->bind($wp.':connection', '', - sub {$zinc->itemconfigure('current', -connectioncolor => 'red')}); - $zinc->bind($wp.':0', '', - sub {$zinc->itemconfigure('current', 0, -border => '')}); - $zinc->bind($wp.':position', '', - sub {$zinc->itemconfigure('current', -symbolcolor => 'green')}); - $zinc->bind($wp.':leader', '', - sub {$zinc->itemconfigure('current', -leadercolor => 'black')}); - $zinc->bind($wp.':connection', '', - sub {$zinc->itemconfigure('current', -connectioncolor => 'green')}); - $zinc->itemconfigure($wp, 0, - -text => "$i", - -filled => 1, - -backcolor => 'gray55'); - $zinc->bind($wp.':position', '<1>', [\&del_way_point]); - $x += (2.0 + rand(8.0)) * $track->{'vx'}; - $y += (2.0 + rand(8.0)) * $track->{'vy'}; - $connected = $wp; - } - $track->{'route'} = $wp; - } - else { - $wp = $track->{'route'}; - while ($wp != $track->{'item'}) { - $track->{'route'} = $zinc->itemcget($wp, -connecteditem); - $zinc->bind($wp.':position', '<1>', ''); - $zinc->bind($wp.':position', '', ''); - $zinc->bind($wp.':position', '', ''); - $zinc->bind($wp.':leader', '', ''); - $zinc->bind($wp.':leader', '', ''); - $zinc->bind($wp.':connection', '', ''); - $zinc->bind($wp.':connection', '', ''); - $zinc->bind($wp.':0', '', ''); - $zinc->bind($wp.':0', '', ''); - $zinc->remove($wp); - $wp = $track->{'route'}; - } - $track->{'route'} = 0; - } -} - -################################################### -# suppression waypoint intermediaire -################################################### -sub find_track { - my ($zinc, $wp) = @_; - my $connected = $wp; - - while ($zinc->type($connected) ne 'track') { - $connected = $zinc->itemcget($connected, -connecteditem); - } - return $connected; -} - -sub del_way_point { - my ($zinc) = @_; - my $wp = $zinc->find('withtag', 'current'); - my $track = $tracks{find_track($zinc, $wp)}; - my $next = $zinc->itemcget($wp, -connecteditem); - my $prev; - my $prevnext; - - $prev = $track->{'route'}; - if ($prev != $wp) { - $prevnext = $zinc->itemcget($prev, -connecteditem); - while ($prevnext != $wp) { - $prev = $prevnext; - $prevnext = $zinc->itemcget($prev, -connecteditem); - } - } - $zinc->itemconfigure($prev, -connecteditem => $next); - $zinc->bind($wp.':position', '<1>', ''); - $zinc->remove($wp); - if ($wp == $track->{'route'}) { - if ($next == $track->{'item'}) { - $track->{'route'} = 0; - } - else { - $track->{'route'} = $next; - } - } -} - -sub stick_wp { - my ($zinc) = @_; - my $ev = $zinc->XEvent(); - - if ($just_wiped) { - $just_wiped = 0; - return; - } - my ($x, $y) = $zinc->transform('radar', [$ev->x, $ev->y]); - my $wp = $zinc->add('waypoint', 'radar', 2, - -position => [$x, $y], - -connectioncolor => 'red', - -symbolcolor => 'red', - -labelformat => 'a2a2+0+0', - -tags => ['text']); - $zinc->itemconfigure($wp, 0, - -text => "$x".'@'."$y", - -color => 'red', - -filled => 1, - -backcolor => 'gray55'); - $zinc->bind($wp.':position', '<1>', [\&wipe_wp]); -} - -sub wipe_wp { - my ($zinc) = @_; - $zinc->remove('current'); - $just_wiped = 1; -} - -$zinc->Tk::bind('<2>', [\&stick_wp]); - - -################################################### -# creation macro -################################################### -#$macro = $zinc->add("tabular", $radar, 10, -# -labelformat => "x40x20+0+0 x40x20+40+0" -# ); -#$zinc->itemconfigure($macro, 0 , -text => "une"); -#$zinc->itemconfigure($macro, 1, -text => "macro"); -#$zinc->itemconfigure($macro, -connecteditem => $track); -#$zinc->bind($macro.":0", "", [ \&borders, "on"]); -#$zinc->bind($macro.":0", "", [ \&borders, "off"]); - -################################################### -# creation ministrip -################################################### -$ministrip = $zinc->add("tabular", $radar, 10, - -labelformat => "x80x20+0+0", - -position => [100, 10]); -$zinc->itemconfigure($ministrip, 0 , -text => 'ministrip'); -$zinc->bind($ministrip.':0', '', - sub {$zinc->itemconfigure('current', 0, -border => 'contour')}); -$zinc->bind($ministrip.':0', '', - sub {$zinc->itemconfigure('current', 0, -border => '')}); - -################################################### -# creation map -################################################### -$mw->videomap("load", "$map_path/videomap_paris-w_90_2", 0, "paris-w"); -$mw->videomap("load", "$map_path/videomap_orly", 17, "orly"); -$mw->videomap("load", "$map_path/hegias_parouest_TE.vid", 0, "paris-ouest"); - -$map = $zinc->add("map", $radar, - -color => 'gray80'); -$zinc->itemconfigure($map, - -mapinfo => 'orly'); - -$map2 = $zinc->add("map", $radar, - -color => 'gray60', - -filled => 1, - -priority => 0, - -fillpattern => AlphaStipple6); -$zinc->itemconfigure($map2, - -mapinfo => 'paris-ouest'); - -$map3 = $zinc->add("map", $radar, - -color => 'gray50'); -$zinc->itemconfigure($map3, - -mapinfo => "paris-w"); - - -################################################### -# Map info -################################################### -#$mw->mapinfo('mpessai', 'create'); -#$mw->mapinfo('mpessai', 'add', 'text', 'normal', 'simple', 0, 200, "Et voilà"); -#$mw->mapinfo('mpessai', 'add', 'line', 'simple', 0, 0, 0, 0, 200); -#$mw->mapinfo('mpessai', 'add', 'line', 'simple', 5, -100, 100, 0, 0); -#$zinc->itemconfigure($map3, -mapinfo => 'mpessai'); - -#$c1= $zinc->add('curve', $radar, [], -# -filled => 1, -# -linewidth => 1, -# -fillcolor => 'blue'); -#$zinc->coords($c1, [200, 200, 300, 200, 300, 300, 200, 300]); -#$zinc->bind($c1, '<1>', sub {$zinc->coords($c1, 'remove', 0);}); -#$zinc->bind($c1, '<2>', sub {$zinc->coords($c1, 'add', 0, [0, 0]);}); -#$zinc->bind($c1, '<3>', sub {$zinc->coords($c1, []);}); -#my $c = $zinc->add('curve', $radar, [], -# -filled => 1, -# -fillcolor => 'red'); -#$zinc->contour($c, 'union', [100, 0, 0, 0, 0, 100, 100, 100]); -#$zinc->contour($c, 'diff', [75, 75, 25, 75, 25, 25, 75, 25]); -#print join(' ', $zinc->coords($c, 0)), "\n"; -#print join(' ', $zinc->coords($c, 1)), "\n"; - - -################################################### -# Rafraichissement des pistes -################################################### -$zinc->repeat($delay, [\&refresh, $zinc]); - -sub refresh { - my ($zinc) = @_; - my $t; - - foreach $t (values(%tracks)) { - $t->{'x'} += $t->{'vx'} * $rate; - $t->{'y'} += $t->{'vy'} * $rate; - $zinc->itemconfigure($t->{'item'}, - -position => [$t->{'x'}, $t->{'y'}]); - } -} - -sub borders { - my($widget, $onoff) = @_; - $onoff = "on" unless $onoff; - my $part = $zinc->currentpart; - my $contour = "noborder"; - $contour = "contour" if ($onoff eq 'on'); - $zinc->itemconfigure('current', $part, -border => $contour) if ($part >= 0); -} - -sub finditems { - my($cornerx, $cornery) = @_; - - print "--- enclosed --->", - join('|', $zinc->find('enclosed',$origx, $origy, $cornerx, $cornery)),"\n"; - print "--- overlapping --->", - join('|',$zinc->find('overlapping',$origx, $origy, $cornerx, $cornery)),"\n\n"; -} - - -MainLoop(); - - -1; diff --git a/sandbox/textexpand.tcl b/sandbox/textexpand.tcl deleted file mode 100644 index f690281..0000000 --- a/sandbox/textexpand.tcl +++ /dev/null @@ -1,6 +0,0 @@ -zinc .z -pack .z - -proc createItem {type params} { - if 1 [concat .z add $type 1 $params] -} diff --git a/sandbox/texture-bois1.xpm b/sandbox/texture-bois1.xpm deleted file mode 100644 index a7a6e5f..0000000 --- a/sandbox/texture-bois1.xpm +++ /dev/null @@ -1,320 +0,0 @@ -/* XPM */ -static char *on[] = { -/* width height num_colors chars_per_pixel */ -" 256 256 57 1", -/* colors */ -". c #f8dca8", -"# c #f8d4a8", -"a c #f8d4a0", -"b c #f8d498", -"c c #f8cca8", -"d c #f8cca0", -"e c #f8cc98", -"f c #f8cc90", -"g c #f8c4a0", -"h c #f8c498", -"i c #f8c490", -"j c #f8c488", -"k c #f8bc98", -"l c #f8bc90", -"m c #f8bc88", -"n c #f8bc80", -"o c #f8b490", -"p c #f8b488", -"q c #f8b480", -"r c #f8b478", -"s c #f8ac88", -"t c #f8ac80", -"u c #f8ac78", -"v c #f8ac70", -"w c #f8a478", -"x c #f8a470", -"y c #f8b488", -"z c #f8b480", -"A c #f8b478", -"B c #f8ac88", -"C c #f8ac80", -"D c #f8ac78", -"E c #f8ac70", -"F c #f8ac68", -"G c #f8a480", -"H c #f8a478", -"I c #f8a470", -"J c #f8a468", -"K c #f8ac80", -"L c #f8ac78", -"M c #f8ac70", -"N c #f8a478", -"O c #f8a470", -"P c #f8a468", -"Q c #f89c70", -"R c #f89c68", -"S c #f8ac78", -"T c #f8a478", -"U c #f8a470", -"V c #f8a468", -"W c #f89c70", -"X c #f89c68", -"Y c #f0a470", -"Z c #f0a468", -"0 c #f09c68", -"1 c #f09068", -"2 c #e09068", -/* pixels */ -"hhehliieid#hqDqliifiiiiiihllhhkllyykhkhdhlpplhggeeehhilmmmllmpppqDDzqmihhhhhhilmODpmqDphhhihhmpqklllpCqlgllllppkhlqDqlhilqtqlhlqplkhltzplmpppmpmqmmmqmmmmquummqqnqqmquEuumlqtppplmqqqpmmpOqmOthuqqqpmmmmqmmmmmiieeefeeefiiimnqnmnqqEIuqquqihhlmlmmmmmmqqlilihilm", -"illmmmllhhilmmpmiimmqqqpllmppppClopplpppklpplkhhlliiillmopptqCCCmmpmmliiliiihilmlllltLDqqtqplmpmqtohhlollpplopplpmlmlllplmpmmpmqCpllpppmpppmllllmlihiihhhiiiheeiiijmmquuutpqlhghmllilllliqlhmldmqpqmqqqqmmmljmiiifeiiiimebaeeeeeiiimqqmmmmlhlmpmlllllllilililill", -"llmmlmlllpqqplmmmmmnqmmmlllpppyCCtzLNNKUCCKKLCCCDqqqtDqtqzDLCtzCDDAtztDDDDtqqqqqqqCqzCCqCDCqqpqpzCCqpCqpCCtqqppqqpppqqqppmpqtCCCNppCDpptqtqqppmqmmlilllimihhhhhheehimmmqllmppllptqlllmpqmqllpmlpiilmmmmmeeddeeeeieeeeeijiiiifiiilimqqqqqpqpmmpmmlmmmmqqqlmmpmmmm", -"mqttqppqDqqCDuqpqrruqqmmCCDLNLNTUNKLNLNKCCKNUUUTDDDDLLCzqCCCzpppqqpmpqqpqqzqqmpqppqpqqzCppqqpppplpqCCDCCqmpCqpqCtqqqCqpmqppqCDDzCppCCztLCzttqqpqmmmmqqqqpmmmmmmilhlmmllqqmmqpmlmililmppmplmmlmpmmmmmqqmiliiiimmmjiiiiiijiiiiiijjmlmnqqqtmmpmllhhlmmpqpmmmmppmmlm", -"DHMMDqDDDqqDDLCnEEIEDDDDIMNUUNNTLNLsyCClolppCCypmmmpqqpmlmmllmppliililiilmqqqmmmmlihkhlimmppllhilhggilpllklpplltmmllllmmllmmpmppppmmpqqtpqqmmlihllmqqmqnmmpmpmpmqpqutmmquqqqqqmllllpqqmmpmqtpqqpppmqqmlhiiehiiiimjjmjiijimnnnmmmmmqtuqqqquuqpqqqqqtqqqpmtqtqqtuu", -"DDLDtqqqmppqqqqquDEDrqqqpppCCzqCpCClmCCpmompyBplmmmmmmmllllllllpmllmmpmmlmmppmmmCplihhdglllmlhhhhhhhppmlhhhlkhhlhlllhiklhhlkillmpppllmpmilppmmmmmqqqqqqqqquuuquuqDOODuuDqqqqDEDruDuDtuuttqtDtuDqEOOOVPDqqqqqqqrqrurvvuuvuuvuvvuuuuvJIuuuDOOuqqtqqqqtqqqqquqqqqDD", -"pqqpmllmlmmmmlmpmqqqmliimmqCCCCCpCzppzCCtqtzCtztpqqqqppqppllppplmlilmmmmlllliililllmpmpqhilmlihlhllqDCplhhliihlllmmmilihhhhihlmpppllmllllmnqqqtutquuqqquqtquququpCNDqqqCrqqqrrrqqqtqpmpqmpmmmmlmlmqtqqmmmmmmnqqqjiimmjjmqnqqqqqnqqquqqqqpqqpmllhihiilllmhihhhimm", -"qqqqpmmmplillmmlmmquqqqqppqzCtqCzppqpppCllllppqCmqqqmmmpmlmpDNKtmliilmmlDrqmmlmpllmpmlillllplhhihhllllihimllhlmpDtmhdgiliihhillmpihmpihipmppmmmmmmmllimmmliiiililqDqmlpmimmmmmnnlpqqplllllihllhlmqtruqqmpnmqqqrqrqqqqnqqmiiimnmmqqqqqmmpmpqqqqqmppmmlillillmlmpq", -"mmpmllmpliillmmlmpqpqqqpmlmpqqtqpqCppmllllpppDKCmqCDzqlhlmppqqCzpmppmmllipqCqpmqptqppllpplillllmkihhhhllmptqplllmihlmqqDpmiilmqqlililmlilmmjlmmqmpmmmmmmmmlillmmtptqqpmmmmmmnnnmmpqqqqqqppplllmpqpmpnpmmmmleimmimjmjmmiiijmjmnqmmmmpmpqqtqppqtqpmmlpmlmqqmmlmpqp", -"pqqqmpqqppmmmlllqDqqmppmmmpqtDCDmomlllkillllmppmtqmlllmlllllpppsqqqtqqpmpmqqqppqmqpmmlilmppllppllllhilillpppllhlppquDDDDDplhhilmpmlhhhilimqqqmmlmmmmmlllpmmmmpqqpllllllmpmiimmqqllmpqpqpllmmppppqqqqqqmmmpmehmmmiiiiiiiimmmlmqnmmmmmmmmmppmllllltquqqmpqmmmqquDu", -"mpmppmppqqtqppmpmmlhhillhlmmqpqqtqqqppppqtqpqztpmmqDDqplDCtCpqypqqqqqqpqzqqqzqqqCDqptpmmpDDpmqpiqmmmllmppmmmmlmlmilqqpmmiihehlmmqqmmmmnqqqnnnmnqtqutuqqqqqqqqqqqtqtttqqtqqpmmmmntqttqtqqqqqtqqqqqqpmmmliqqnlimnmmiliiiljqmmjmnmmpqqqpmlmllmppqqtmpmpmpmmqqpmpmli", -"pmpqqqqpmmpqmmmmCzqqqqtDtuDDCuDDDCCtCzDzCCDCCDDtLDqzDDLMNOLLLCCCLDLDDDDDDzqzDDDDLLCtLDqqpCCqpqqpDtqpmmqqqqmppqqmqqmqqnppDDuDuqqqpmqqqqqnqnmmmmqumqnqqqqnpmpmpmpmllmmqpmlmmmmmpmmmpmmpmllmppmpmllmlmmmmqpmnpiiilimmjiilmmqnmimmmimmmmllllmmppmlllipqmquuqlmmmqqqq", -"tqtDDLDtMHMOUXOOOOMLLDDDDMHDuDOOpqpqqtqpmqpmpppmDqqqqqptmmptCCCzqqqqzzDDzqmqCzqpqtmpCzppmmmpqqCDzqmmmpmmqppqqqqmtqtDqqqqpmmmllilnpnqqqmimmqqnqnnmmlmmpnpqqnqmqmqqqqqqqpmhhhlpqttolmopqtqtpqppqttqtqqquuEquuuqqqqmmmmmmmqrqmmmmmmhilmlilippptuwtpqrtqqDDquutuDDOO", -"qqmqqtqqmllmpqmmlmpzqmmlllmilmpqqqqzCCqplmplllllmmpzqlhdkllllllkhhhhilmmmlilmmiimplhmpllphhllhhlmliillllmmmlmmmmllmqpmilqmlllmqtliimmmmjmnnnmmmmmpnqqqtrqtqtuuuupmmllpqppppqtuwIIHuuHIIHIIHuuuuHDuuqqrDIvEIFJIJJuvuuuruuxvuvvuqqmqquuuuwqqtIOXOEDIMDOOOODDDqqqqq", -"liliililhihiilllilmqqmllihhillmmtqpqttqplmpmlmppDmiihhhmmpllhhggiihilmqtlhhhihhhmlihlihllhhhhddchedhimmlmllillmliimmmiheqmjhedeeiimmjiimmmiiffijliihiimpmmpmqqquvuuruvxuIxuttwttutqpqpqpttqppmpmqnpmmmmmmmmmqnmnquvvurqruuvxxrqruuvuxuIIwutqqllhhehlmliihiiiilmm", -"ihihhhhihhlililmppqCCmiilillmmlllkhhhlhhhllllppqmihlmilmCqlhhhghhehhimqqmihhhhilpmlhhhhheddhlpleedeimqqqmmliiimmiiiiedeheiliihehimqqidaaaeeiieeeihhdehiiddddeimmmnqquvtptqtttpoohhdgllmlihllllklhhiihehhmihehiiiiimmiieemmqrqmimqqqmllllmpplllllmlmqqlhelmmliheh", -"qqqtDuqqpmqqqtMUqqmqqqqtDuDMIDuDODqtqmptDqqtDqqqpqCDDpmppDOOCmlllllqpklppmlhhhgddhhipidlllhimle#ddddghd#hdddddgheheemjeimiimieeeehiimmiiiiieeimmiieeeiedeeeeeeehiiinqnmiimmqmliimqqrqmmqihimmmiillllqmmqmmmmmheedeiiiililmmmiilljnnqnjjnmnnmmlnqtqplimmlqmmppmmm", -"qqqqmlmmqmqqlhmpqqmpqmpnlllmlliihhhmpqpmLCqCzqpqlllmmmptmpqpmpqDpmpDDqpqpppqmpmpmzqmppmlmmmmmmlhllllllhhhihhhdddiieimieeadeimilihehilqquqmmihiimmmiilmmimifeeheeeefjmnmnmqpnpnpqmmqqqmmpuqtuuqqqmpmqDqpqqqqqqmmmmppqqtutqppmllilnmmnmnnrqqqrqruuqqrqquEIqqqqqqpq", -"qDDDpllpmmqqilquqpmlllllqmlmmllmlllpCLqllllmplpqDphlptqplllihllmmllqCqmhilmmmlllqCLqmDLpqqtppmpqtqqqpqqtppqqpmllmmlmpmhhhilptqpmDuqqmqqqOJEuuruuqruuruuuqqmmmmmmmmpmmmpquuqtqtuuutqtuuqqqqttqppqmpqtDqmmpmmqqmmmpmmmpqqqqqqquqtqvrqrruvEuuruuqqqqDuqmllmuqmmmmqq", -"imtqmlilhhlmllqqCqpmmmmpqmllmmmmtqplpqmhllllmmpptpmlllihqpmppmpmpllqCqlhlllmppmledhhdlphdhhhdddhilhhhlpDqtDCztDLqqpmuqlmqppqqqikiillliilmmliihiiimmjlimjrqqqqrrururqqqnqqqqttuqpqpmmppllllmqpmmplqqqDqllihlmmmmmqpmilmpmqqpqquuqqmjmmmqqrqqqqqmilmmmlillqqpmpmqu", -"CDNONDDCUNNHCDLCLDCqCCDDLCzCDKLNOULCDUUDNDqtCDCqmqDCplmpmlhdhhlpppqqpmllqmllqqqpphmplmqmllmpmlllhhlllhlphhhdddipllilqmlllihlllhgilmmmlmlihiihfhilmmmiiilimqqqmpqmpmmmqpmpmmpqppppllpmlllpmppttqtqCtyCtmplllmpmppmmmhhilmmmlmmmmlqnqqqqqqlmqtqqtqpppqtDHtmptOHDtq", -"CtpppCtqCppmptCpLKCzCLLLCmlppqpppppqqDCqCqpmCOLCONLDDDCtDDCDCDDCmqtqpmppCpllmpllldhlllmplllmpmihlmqDqlhlqqmlhhlpllhlplillkhhlhkliliihehhiiliieieieilihhiimmqmmmmmmmlpqqlqpmmpttDtttCttDIDtpqtuDHCLCqCCqqqppqqpmpmmplilmmpmmmppmmimmqmmmqpqtuttuuCuttDDqpqtqCCtDO", -"CppqCCCCllllpKONzCzpyCKCKypzKCypLqptKDqpllhhmzCpODpmqCqipqCDDqmlqCDDCtqDODtqqppppqmlqtttpqttttppllpqpihhmllhhhhhpplkppkopmopopopmmmpquDDqqqnpmmmqqqruqqtqqqnqnqqpqqmmtqpqtttqtCHqppqtptCtppppsqttCCpCCppqpppppmpquuqqruuqqqqqquutqquHDtuDCttqtppllllppplCqpmlmCN", -"lpsCLCCslkkkkpCCyCCyzKCypplpyplhOpilqqpmpmlllpmllCUDpmpCllllihhlhlmpmmpmpqCqpqDDDXtlpCqqmptqpmlltpmqqmpDppppqqppLCplpplppoppppptDCtquqqntrtqqqqqnmmqqqnqvqqqtuuqpqtqpuDuptCttppptpppollpklpttppplCppptppppmppompuqqqqqqmqqqqpmmmqppqtqpmttmppqpplppolllllpptpppp", -"DCKNNUULNDDNNNCzNYULNYUKCKKCKLKCLLDNUOzzppqqqpqqCzqpmppphllhhhllhhipplllqNqhlmlllmlpqtqphlmpqpmlhhhhltCzqzqtzqpmCCptppptppptsttpppqpmpqtmmmpqqqqimplilmmqpmqqqmiipqmmqqqmptqppptpllpmllmlppppCDtptCCCCCDpllmpmllmmmquuqliqnpmlmummqtqpqCqqpptpkllqCqptCpNHLNLNOU", -"CqCLCCCsppompCLNKNSKLTTKUUTSUYYTLNDOYUNOCDLDLLOUOOLNNLOOzCCqtCqpqppqqpppmqmhlhdhlllhhlhghhllllhhllllhlllCtzqqpmlpmolplolspstpptompnppmqqqpmmmllilmmmilmmiihilmlhimmmpqtpmpppppppmpptCCCHtDNDDONDYWNCCLNONtpppppplilimliiilmilehnlilqqmmqlCDpCNNHNUNCCCOOCCCtCtpq", -"olpsmpplCpolmpCLpppppqpmppllpDzpqqppDCqCzCCppmpCCqqztqqCpqpqzCqmOODLDDDLDNCDDtqDtqqppqqmtqCqtqqpqzqplillllllpmpmppppppppplpppppoDCDDztCDqqqqqqpmmpqpmmlmppmpqqqpmmmmpDqqqqqDOUOLNOOLDtplpqCqpqqmlllpptqqqmllllpqqtqqqqqtuDuuuutDDtDELDtDCWVCqCqpLtmlhhhlllmmpmll", -"ppCLtCCtppppopppOLCDKzzLLCCCLTNCqzqzDzpqCqqpppqzCppDCmlqmpqCDONCqppppmppqpllllmtqztqqCtqpqqCCCCDqCDzqqpmqqqCDDDCCCCCCCzpLCCNCGHCqqqpqpqqqqqqqurqtutqqttuqquuuqpqntDruDLDDqqqzqpmillllllhmqqqptqppppqCCpkmpqqtqquqmqqqqqqqqmmqmmqDqpqCqqqlmlmlhglihlqzqDOCDCDDDCq", -"ihmmihlilmmmpmpqpmlpmllpmqqpmqqqptqCLCpqpmmpCDNDDqqNDppCpqDCDLLOCCzCDDDDLNDmlqCpppqmlmllhlmqqqqzppppqCzqCCCqCzqqpppppmppllllllmlpppmpmpmpmmpqmppmmlllmpqmpmllilimnqqmmnqqqmmpqqqpqtqqMODqtztqDCqCqmmpmmmhmmpmiihiiiimmliiihimlimmiiimmpnqCtDONtLDDDDCmlmmmmmllil", -"DtCtpmplmmmmmqqqmmmqpmmqmqqqpppqilmpqpimlllmpppmpmpqqmpqmpqmlllllmmppqCqqqCphpqhmpqppmpmlmpzzpqplmlmpqtmpmmpmpompmpmppppzpptptCppqqqqqqqqqqmqqpmlihiiimppmlhhimpinqniiimmmqqqDLOqqnmllmlmpmmmmmmlhllmppmqqtnpmpmmmmpqnmlnpmmqqmqrpjlmnpqpDCmpqmhihilmmqqmmmmmqqq", -"qmnqmmqmqqpppmpmlllmliillmppmmmlmppqCplpmppppmmmlpqqpppqpqpmllllppqpqCDCpmqplqCmhlmmmmmlilpppmmmmmpmmpppmpppqqCCmqppmppqplmplmpmlhlllmllmmmmpmqpqpmpqppqqpmllpqunqrrqnqrqqqqmmmjqmmmmmmqqnmmmmmmqDDMDqqmmmmiiimimmmmmlmlhieimmhiqnmjimiihqqlmqqpDrqqmqqqhhiimmmn", -"lhlmmqDqmllmnpmlquuqmmmlilmmqqpmppmmmlhmkmqqmptDlpplllmmllllpqplmqqmpqCqOppqllqqmmzppllilmmqmmmpmpppllmmlmllmlmmmmllmlmmmllmllmlllllppmllhihihhehdhiihehihhiilllffijifiifiimmmmlqmqqqmmnmmliilmmilillmqqqqqmiiieehiheeijlmlmqmiliiiimmmmlmlilhiqimmiimjhmmmqmmml", -"qmlilmptlpCtpollkllloohkloplkklpqmmqqmmmmmmmlmqzlmqDVtlimmmtEDqmmppqqqqCqpmpqqpplmqzDqmlhlpppoopppmllpolkkllkllplliillmllmllillmlillmmpmmqqmiiiimiiiliiinnmmnqqrilmmmmmnuqnmmmmimiijmmlillmpppppllplilmqutmmmmiilimillmmlihllmlimmmmmquummmllhilillillllnppllllm", -"qtppptDCCLOLtCCCDNCpCCCCCCCDCDNNMEOOPMDEnqqqnpmmqCqmqnpDDtpmpmmlqqCCtCCDzqpmmpqCmmmpmpmpllppppopzqmllllklllllllmlllilmmmmpqqqmihiiilmmmmqqqmmmiiifhijmjmlmiiiiiiimmnmmmmqqqmmmmmmmmmjmlimmppmlllmpqllilmqqqmqqmiiiiiiihillmlllllmqnmimmmmllillllllilmqqmpmpmpqqu", -"NMDDLDLDLOUNLCDNCDCtDCtCCtCCNNNLDDDMLDDDDDDDODqqtDDDDtqNMDtqqtCttCDDCDLNDDDtpqDLtqqqqqsqpqCLCCCCzLCzpCypklkhhhiliihhilllmmmmmlmmllpmmmmmmmmllmmiiiiiiiiimmmmmmmmmimmmmmlnmmmmmmmjjmmmmpqqtqttttpqtutqqqpnqquvurqqqqqqqqmmmpppmppruqmmlllqmlllllimmmmpzqqDEDDuDHO", -"nppqqqpppCDCtpplppppCtmppppptqqpqqqtqqqqCqnppqqpmqDDLzpqpqDDDMMDDLLNLLOVqCCCCtztACqCqzqpCCCLCKLLLLLDKLLKCCCtqqqqppmmmpmpmmllllmplmmpmpmpqmmmmmihmmijmlimmjmmmmmmiiimqqmmmmmmqqnqnqqqnquEutuuutttpqutqqqqqqmmqqrqrrqrquuuqtutqttuqqrqqqnpmmmpquDDDDtqDMICqCtqpmpq", -"pmqnqqtztLONLNCCtDCDOLCCCDLDCCCtLLNLDCDLqtpmllpqpqplttpplpqsqCplmpqqpqCCpmmpqqplqmlmqqmimmppppppqzzzyCKCCCCCCzqpmmmmpmmmqqquqmlihlmmpqquvuqqqqmimmmqqquvqqqmmmmmmmmqqqqnqqqruuurDEIEqqqutuqtqqplmpqmpmqpmmilimmmmmmmmmnqqqmppqqpnqqrtrtutuDutuDODzqpzDCmpmppqqqu", -"OODDDDDCMOTLHNONLLCpCDCDNNNONLNNMOOLDLNOOUOODCzDLNCtLNLHDNCzsCCpmppqppqqDpmlqqqpqmlimpmmlpppppppqzzppppollpmppliiilimmmmqqqqqmmmmmpqqqqqqqqruurqqqqqqqruvvurqruurtrruruquuuuuuruuEEuqmqrtqpqttqptuutqqpmmqqmnmnmqqqmmmqqqpmmpqppuuuDuqqqtDDupmqtqqmmqqqpquDDuDHO", -"DqqqqmmlpqppmpppqtpmqpqCCDCCDDDDpCCCCCCCCDLCCqppCNNLUUNLNNCCCNOCDLOOEDDDDqppqCtqzqqqqqCqpqqACzqqzDLzppzyCptpqqqmppmqqtqqmmmmmmqqqqqpqmmmmimqruqrrqqnmmmnqnnpnqqqurtrqqquqrqqrrqnqqqqqqtuqtqtuDuuuwDutqqmmmqqqqqqrruuqqquuuttuuuuEEEuqqmqlmpqqqDILLDDDNDDtqqppmpm", -"lmmpqqttmpqqtCtpqzqpCCqzDqmpzCzplpCDCCDCCtpppqpplCpopppCppplpCClpqqqplilllmmmmllmpzDzqqqmmqCqqppzLLzzCCCCCppqqmpmmmmmmmmlmqqpmmmlliimmmlpmmqqmmmqnnmmimqmmmmmmjjmpnqmmnqqqqqtuqqDDEEDuuDHuqqtqpmlpqqqqmlhihiiiimelnnlimmlmmlillpmmmqqqqDIODDqtqqDDCqmqqmpqppmlll", -"mmmmqtqmmpqpppuOptLUVLqqpCtmpCtmppCNODppqppqCCqpsqtpCCNNoppppCCpqpqCDqtCqpqpmlheelmllmmilliihihimmlillllkhllpmllmmmmmmpqmmimmqqmmqplipqmmlmmmimqqmlqqqmqqquuuuuutuuuqtqtuEOOEuqqqmpqqqlhmmmpqqqqlmllmlmmmmmmmmmimqrqmmmmmmlllllmmmmmqquuqutqqmlmlqqpllmlmmpqttql", -"mmpqqqtuttqqmpptmlppqpppCDLtqLODNDLLKtppCCCCDCCCCCLNCCCpqCpppppoqmpqqqqqmmllliihhimmqpmmlmlihhhilmmmpplhghkllliiiilmiljlqmmmiiiihililiiliimqqmmnlhilmilmllimmmmlmmqqmmpnmqqqqqqqqqpmpmqqpmmmqqqqppmppquuuuurqqnmimnmmqqmpqtqqqqtqqqnmmmmmmppqttuCqpnDDtmppmqqqml", -"mqruuuDOOECqppqtDqqtqCDOELOLDDMUUUOONDDLqCDCCCqCNKtqCCDLNONDDNCqqmmmllmplliiihhhilpqDqmlimmmiiimilmmmplhhhikiiiilmmmmmminqqmliimlhlmmllmilmqqnmmilmmmllmmllmpqmlilllmlllilillmpqquuqpqDOutqpqpqqlmlmmqqumqqqnqqqqqqqqqqqqqtuttqqmnmmmllllmmmmqtDDqmtHMtpqqquuttt", -"qqtuqqDDutqtqqqtqpqqqqqzLDDODqCDCtqCqqCNOUUVUOUVUDqtCLNNCqBqCtCtqqpmmmpnDLIDtqmmmmqDLqmmmmmliiimimmmomplkklillilmmmmqqnqmpmqnqqrtqppmmqqqqqmnqqqqrutqqqqmlilmnpmmmmpmmmmpppmmmpqqqCtqquDuuqqqqqqlllllmmmimqmqquurqjmmqqqmqqqtqppruqrtqurqqqpqquDDtDDDqqupmptqpmt", -"nmmmmmmmmmpqqqtpqCqqtztqCqpzDqmpqqqqqqCEqzDtqqqCDDLUVODDDLDOOUOOMLDDDDDDqqqqqppppmpDLqqqqmmmmmmjililillkllllllmmqqnqnqqqlmmnqquuquqmlpqmunmlmmnqqtuquuqppmpmppqqpqqqqtqqqrqtqtqtDHDOODDtnqqqqqqqlmpmpmllimmlimmnihhimqqmlllpmpqqqqqnqqqqqttuDDDDHEOOtmpDtqpppill", -"qmiilmlihllmplmmmmlhehhimiippmlimmpqqqqLqqqqqqqqqmptCqzDmmlmmmmmttAtqCqqqtDCDEVXCtADqqpqqqmnrDErDMOONDtpmpqtqpqqqqmmmmliijmmmnmmlqtmmqqimmlimmmipmmpqqqmuutqmqqtnpmqquuDqtqquDuuLDtCDHuqpqqrqnmmllmpmpmliliilmmihfjqqqmlmmlllllmiiiiimmpqqtqqpqpqqqqpllmpmmmllll", -"qmmmqqqpmpqpmllptCqmmmpmmllmmmlliiilmmmmiifhhiiilhhiilqOqpmmpmllimmmmnqpmnnqnqqDqCCplmmmnmmnrrAAimmmlihhpptqqpmqqnmlmiihiimmmiiihmmmmmmliihhimmillimmllpqmihhimppmmmmpqqqnppnpmmllhlpmlhmmqmmliillllllllqqqqqrqnmmquqqmqqpllllllmmmqqqqqmpmlllhilmpmmllhhhkhlpql", -"rqqqrvuuuDutqpquzDDqqqqmtDuqpmqqErqqnmlilihiiliiihilihmDpmllmihimmmmmqrqquDDqihehlmlilpqqmmiieeeeehddehhhlmpmimlqnmmmmieeimmmiimlhilliimihedimnmihhllehmplhhimqqqmlhlilltqmllihhllpqDtqmhiiiiimmllihiiimmmlmmnmhqqnqnmuJqnppqtqtnqqqqmlihihhhimpltODqpmlpqtptOIt", -"pqqpmppqmqpmpCCpDDqlmllpmqLDqpmmtmmpqppqqqppmqqpqqmllmpmqqquqpqmlmilmtzpdihmmhiehhlpqmmmlmjimrqnlliiihhiliiedeimhhlkihklmllpplklmlilmmlllqnpqqquilpqpmmmmihipuqlimmiilmiehhehimmpplmquqtqqtHqhiqimihhmqqlimmmmmqhilmmllmpmmmmmmluqpmlmpmlmpruqttqqqqmptIXDmilppp", -"qqDDDDztlqtsptplCDqlpqqtLCqCDCqplqqiimmhqqqqqqqqqDDDDDqqqqqpmpnqmpmmqqmhqqqqqlmhdehhiheheeeeeiieiiiiiiiihiihehimhklllhhhplpttpmpuurqqpieilliiihmpmllmqqqlpqpmpqqquunmqqqtrttqtttmqpptqpmqDODplllmmmiiimmmmpqmmlmllmqqpmlutpmmppmqtqqqtttqqqqpmmmmqqtqqqDDDtDDDzp", -"mpqtDDplmpzCCCqsmCqptCplqlllpmllqNIqpqqllmlmppqqqDDDCqqlqqqDtqpmqqqCDLuqmDqqpmqlllillihiilihiiiiiillllljlmpnlmmqlmpqqqpmtqqqtmpqqqqqqmidmqmmmiimtmihllllmmllmmmlnrqmlmqmlmmppmmmlmmmqtmmqDOIuutqqqqpmmmlqpmqmlmmmllpqmmltqmmqtqtlmpmmmmquqpqpmlpmmpppqtqDtqqCDDD", -"ODqzDLDCLtpqCCCNCDDLULqDCqqDtppDHuqttqppmpppmmmmlmpmqDLDqqqqqmllihilquzqlqmlmqDmqppqqqqqqqqmmmmmmmqqnmmmmqqqqqqqpqquttqqqppqpmlmmmmmmmieimmilieiqplmqqmhpmlmptqmlmrqnqmmqqtutqtuppllqqptplqLDqqDvEvurtqqqqnpmqquDuqqqttDuqppquDupuDuqqqqqqpmqqqqmqpqqqqqODCppqLO", -"VDqCMHDD0DppqqptzppDLqCYCDNUUzqDLCpzLDCqCDDCpplllmlilmpqqmlhhillmmllmlmmqtmmpqCqllmpqpmpmpmmmiljlmpmpmmpmmmqqqqmmmmmmmmmiimmmmmqpppmpmllelimpmllilmpqpmmhmqqmmqtjqqrqqqmqpmmlillutqpqppqIqtOOtqHIOEutrqqqpqqtqtutqqtqqquDutrutqmqDDDttqtmmpqqqqqtuqqtDDuDOOMLDDL", -"CqmtCqppLCqptCpllllCDllDppqqCtmlzLLpC0UtpCLLDCptqtqpmpmlpmpqCqqmDtqqqpmlqqlpnmqmlllmmmlimlmmmiiihimmmlmpmllmqtqmqpmllllimmmmlllmqmmmmmmpmpqquqqqmppmmmppmqqppqqqqqrqqmqqIqqttqtDqqquDuqDOOODDOODqqqmmmlilmqqtmmmhimpplllqqqqqpmllmppnqqpqtuqqtqqquuqtEHtqtLNDCtq", -"qqCOMDzDqCCCCCCppDLOUqmCqDDqqCtplCKppKCkhoCNLCKCpqCDOU00mqDUXUDqCpptppppqplptlppqmlmppmlmmlmqmllimmpmmmqpqpqqqqqrqpnmnmmqqqmmimmlmmmmpqqmqmmpmlmuuutpqqqxutruIutuEEDuuuEqpmqODqtmpptDtqDpqqptDtmqqmllmlimmptqmlllmqutqmmllppqqqqqqqqtDuqtDEtqqqtmqqqqtqqqqtqpppt", -"DqDOODDUtUUDCDCtLVNqCNUVCU0CpqLOsKTNKBployNTKCpompmlpqCDCqpqDLDCOLtzCtCOUDpLNppptpllpmppmllqqqmjpqtqpmqtqqrqmlmpqmmmmqqqmnqpmmqrqqtqqqqtqtmilihihhlmmppqmpqpmpqqmnquqqqtpiltDtlhqpmmqmpDummuOtqtqququuuqtqqqqpqquqpqqqqpqquuutuHOuqqtDumpqtpllqqlqtqqqtmCDNLDCqq", -"qtzDDLDDCqtpCLCppmpDLDqpVNDDDDLOKNUKCNLWYCyKCpoC0mlqlpzlpCDqpqCqptNUNzsLKKCHNDCUNDtDHDqtqqqmqDDqplmpmppmqmpphpuqqqruuuqqqqqnmqqqlpmlpqqqpqplhhihhimpqqqqmhhiquqpimmnqqnqqpmllptEqqpqtDqqtpqNPODDODqpqqqqpqqtqtqtpppmpppppmpmpqqqqpqmmpqtrqquDDutJEutuIDqDOUONUOC", -"qqppqDLLLLDCDNCqplpqDCDCNCqzCDNOUKCBKUBlNKCKKKKNUtCCqNOCqCCCqpllCpCNCppCtCppCCCCHqptDDtquHEDDOEuItuuuuutqtuIuDIuvuIIvuqqiiillmmquuuttuwupqqpqtttqqqqqqpmmpqqqqquqqqqqtuuIIDuuuDItEPODtDPUDtDHCtDutqqpqqqqpqqqpppmmmpmmlmlllllllhqmpmpnqqDtqDDutDuutqtDDttDqllpqm", -"DzqqqqqttDCCDNNNqppqCCCDAppqCDDCpCYNCCsKNKCCCKCCpDDCCOUDOCCUULtCNKCCCpCKCNCpCNKsLtpqCCqppqtqpqqpppqqmlplkipplppillmppmmlqqpqqqqqttttqttqtttqpqtqtqttqtqqqtuuqpqtqqnqqqquutqpqpppltDDpmptqqqDDqmmqqutqpqqpqqpqqpqpptqtppmpqpqppliqpqpqqtqtqqpqmqqqutqmpmpENDpmqCt", -"qqqqqqppqzCCCCLNUOLLDDLLtqqqqqpqCCKCLTCCCNCBCCKBpDLCCLCNppqDNLDNYNLNNNTWNTNKTUNNUDtCDDtpDDDqqqDDqptqomplqttpmppmqqquuuuutqpmqqpmmppmppqptutpppppmqpqqqttqqmpqqpmmmmmmmqmmmpppmmmmpquuqpmmpuOHqpqpqtqtqqtqqttttqttuuuutqqttttuttqqqmqqtqqtqqqqqqqEIOuqqtqqqqppqpm", -"lmpqCCCzDNDCpqszNLHCCqtqtCDCqpqtLCGstCpoCCCttNUHzCCDDqtNpCDCqCCDNKGCKNNTKNNWYGBNWUONNNDDUODtDOOIttuuqtutuHuqpqpqllppqpllmlllppplppqpppqppqpmpqqqqpmpppqqpmlmqqplnqpnpmmmlpqqppppqqpqDDtputqqmpqDqqqqtuttttqqqtqtqtqppqppqqqqqqqqqpqqqqpmmpppmppqquuqpqqDmpqqqpml", -"qqCqDDDOLOTDCCCtqtzqpqztqCDCCDDDstOCoppDCHCpCDNCCtCLCtCMpNOCCLNNKGCCCCCCGCKWWCpWNNNDDLNNutqqDDtqqpqppqtplpplmlhkmppttqtttpppppppmttqpppppqqqqttpquqqqqqqqquuutuuquuuttqqlpqqppqqqqqppqqDqqqqqquDHDtDDMHDutttqpqpqqpmlmmpqpmlppmppmppqpqplmmmpnpmpqqpmpqqOONLLDDD", -"OOOLDDDLDDNLDNNLLNODDLNLzCDDLNOLNtCqH0NGDHDDCCtpCptNCCNCoppptCLNKKKKKKNNNNKNTKGYCNCCCLHDDDCDDDtqtqpppuupqDututmpolptuwuwttqpppppqtutqqtqttuttuqpqqqutuuutuIxuquuqqqruuuuutttuuHHtuDutqDIqtHOOOOOLDDDDDDDtqqqtqtqttqpppqttqqqqqqpqqqqqqqquuuquIIHEEDuDEDuNEDNDDDD", -"DLOOLCztCDLDCLCCDLLqppqqNDCCNVUDHLXNDODOCCHNOHCtNzNLCNUpCpCNTNCNGNNNNWYYNTKCNNNWWONCHUODOONDDtDDHutqqHIqtOuptplpqttHIHHHuuwuwIIRuIOOIIIOuDIIIIutmmppmpmmqqtqqpmmqmqmpqquuqmpuOIuqqqqutqmttqqpqtqpqqqpppqqqtqtuuwuuuttuuututuwuutqqqtqtuIDtqptDEDuuttDXOOtCCDNLDD", -"mqCqqpqqCqqDDqqqNppqmlpqpmmpmpmlqDOW0UtDDDMOOVVOMOUNLVNCDNDLNLNLNCHUNCtNNNONONNNWNHNGGNNWGCHNNHHquIuuIDtuIOIDuutIuuOItqutttuuttptpqqqttututqtqttqplimmllllilhlmpunmmmimqqlhlmlllqqpmllqtqpqqtpmpptNptpCpptCtppppHIHutppqqpqquuruqttuRXItqqttuutqDMDDDDCqqqtzCCCs", -"tDDDzqCDDpmqqpmqplpplpqpillilpmmlpmtDtqqmppqtDHDDOOOUY0UNNTOUUUUNUUNOWYWWOQQOWRW1WTWNWWN0WNNQHCHDIOIHEutIDwutqtqpmpppmtElllmpqqtqpppmlmppppqqqqpuqppqtqpmmplmlppumimlilmqlhmpppqpmpmmmpqqqtDDtqtosCoptHCsCtptttppplllmppqmmqqqrullmqtqpmttpppqttpqCqqqzqpppppppl", -"CCCqtqtqUDtLDCCDCNLzpCDlpqqpmutlmqpipmmpmpqppqqpqCDuDODtDDDHHNONUWYOW01UWXWOOQXWWNNQWW1WWQQXUQOWIIHOIuttDuqqppppqpmpmlpuqqmlllllqpmpmlllmlmpqppmlmmmmmmmqqqqpppqqmiimlimqmlmpmqtppmpqtqpqqtDDtqqqCqqpCDDNDCtCLDtplhhllqqplilmmqrklppmlppqppmmpqtqqCqpqppLCqqCDCt", -"DCqqqtzCLCqCDCqCLKCtllphmppmmpmhptmhllllqqqqpmmlmqqqpqplppppqtCtCttCCsptCtpppppptoossCHttCHDtttDutqutppqqttmlilmmlmppmllqpppmpmpqqpqppmmpmppttqpqqtttttuttttqqqqqqqrqqquqqqtuttuDuDDIDDDEHEOIMHDHOCHqODNOONDNOONwtpllpqtlliiilmqllmplpqtllpppqqqqDDDqqmpDqppCCCt", -"NLDCKNNNDCCLNNLCNCCDzptCplpttpmlimlllllllppmmmplmmqqqqqpmpmppqqtpmmtuqtqDDututuuHsppptDtDwDtppmppmmqqmlppqqplhlpqpquuuttqqqqtqtqqqqqtqpqqqqquuuutuuuutuutuuutqtquvPIIuuIuuIOPIIOIOXOOOIOOOOHIOIILNCOCWOUNONUOUOUDwuttqtqpmpmlmqqlppppqttmptutttqtCDDDDCDCqptCLLK", -"OTUTUUUUNTUWUWUW0LNYONVWOuDPVuqtpqqqDqmpmqqpmlmlpqqqmpmppppmppppqDDqqOEplllllmpptpopptHHtDtqmlpmlllppppqptuuppptIuuuHIuuqtttqppmqqpqqmpqqpppmqqqmppmlllmqqqqqpqqquIvqmnqqquwHDHuuDOIuttDIDuttDDttCtDCDCtCDNONCNOHIOIDuuIuIEuuuuuuuuuHHEDIOOIHDHIOMOUOMLNOONOUWWX", -"CHNNNNNWCHNNNNNNUNOONLODUDDHDtqqOIDQVDqDtDDutqpqqqqqqmmmqqpppmppquqlmtqiqqpmpppqhhlllpuuqtqmmmnmppppmqqqqttttqqttutpmmpplpqttututqnqnpmpmnqqmmmppmmmlmlmlpmpmmmpqnqmmllilmpmqqqqqtqqppqtDHDDIOIDqtLNDtqqqtCDtqCOIHIDHuDwDIIuttuuHDHIIIHIOROOwDIOXODMOHDDCDLCDDLN", -"sCCNGCNNNNTNCKNWLTUNLOUCDDtqCDIHDttOWDtVtDODCDDDqrqqqqtuuqqqmpqpuqmmmqqquuqpmmqqttuHuuIHXWPHvIIxqtqmpqtppmmmpqqpqtutpqtuuuuuqqppqqpqpqqqquuutqqqqqpppppqpmppppqtrqnmmnqqqpmpqtqptqppqqqqpqtquHDqqqXO0LONtqqqqqCOHuppmpplqttmllmmmptuttttttutqtuDOqqtDDtCqtCCtpst", -"tCCtstCNNCtspstCNNNLDCttDHDDutquDDDOOVOHDDDDDDDIrvIJIvuuPuuIRItuODqtuEIEQIuqtuuuqtqqqtuuvurqqqqrpqqtttuEtutuIIutqppqwDtpppllmmmliiihmqqqmmmmiihhhhhilmmmqqtuuuutrqqquurqqqtIHuttuDuuuuHuuuttuttqDtmtNODqqtCDCttCqqqtqtttpmihhllopppmpmqtutqpqtttqtDOODCquW0NCDCp", -"pssspstCsssCHNCGCNUNHDDtppqtqpqtODCqtDDDqtCuCuDDuuIEuuquqqtuDttuDqquOOIIEuquuuqptqquxuqtuqqqqqqnpquuwuuuqpmlmpllilmpqplhmmlllllmtqmmmqqmmmmmmmnnpppqppppqqqtuuuuuuuvuExuIuuIIIIPQROOIHDHDuuDIIDwCtCDUXUODDHHDDLOOIHuuuuqtqpqppqpqquutttqpppqtqqtpqqtttqpCuCtCCCt", -"CCDCttCCtCHNOUONpDNLCCCtqtqqqppqIODDqqDDMHMDDtqqquDuqmpqpEWXOItqIuEOIEutIIuIJIxuIuuQWRuxqtqrrqqmlpppqttpuqpllmpplptqqpmmpqtpmlptuqmmmqnmqqmqtrttmmmmlmilllmmmpmpnnnqqqmmmmmllpqptttqppmlppmpppppqqDDDDDDqtqtDHOXWVOIDDttutDwHttttuHIIIDwOOIIIIHuuDDDDDDHDCHUXOtp", -"CHDHCNNOWONNNHNDGUWXOOOONHDHDtuupqqqqppmINODtqqpuDEEqqqtqDHqppqtuDuuuqmquuttqttuutptuttqqqqqqqnqqtqmpuDtutpqqttuqqqpmpqtppqqlmpqqqqmnqqtuqqqqqqmmpmlmmpmqqpppmmlmmpnmmmlpquttutqmpmpmmpppmpppmmllmqqpmompmmpqqDLIutqtqqqtttttttpttttttDIIDtqtqqtqqtqutDCqtDW1YNt", -"pppptDOXWODttqtttNUONDHNutuDIHIIODHDOOIDqqttqqttqqtqqqppltHDHNHtmpmpmlptuuuqpmqtwHuqquuupmmpqqqquutppDIuqpqqtqqquttqtuuIuttqtqtuqruuurvIvuqnqqmmppppppqqqtqqpppmqqnmmmpqmqtqpqqmsqsqttuututtqpppmpqqqtqttqtqqpqpqqpppqppttCCppppqpmpmqqppllllpppppppqqppIOHqptGt", -"pppppttuttqppppplptppomptqqtuttuDqmpptDttDuCqtCDqpmqtqqqlptCDtplqqpppqtuPQXOwttupuuplttqqtqnqqtrqtqqqutqtquIHtqtuttuIIHDIuttuuutuuvurqqvurruuvrrtqqqpppqqppmpmppnqqqqquvIIIuuuDIttutuuwwtuuuttttuDDDDDDODDDDDDqquuuuDDuDNOOOHCCCqttttqppmppqttqqqqqtqtqtHOHpkppk", -"uttqqqppqpqqttqqCNDCtttqtsqqtqqqODtqqtDDMDDtqqqqDDDCDOUW20NCpCLWOIDIDuuwuIIIuqtqtwIwuuwuuuqtqurtqttuttttxtuIuqqtmlmpqqpmpmlllpmlrqqrqqqnqqrruuuuuutqqqqtqqqqqqqtruuuuuEIDEDutqtIuuwuuuuuttwuuuuuDDDtqqqDtqtDHDDDDCDDDHDDDNONNHGHwuuHIwutttuuuutqtqtqtqtqlttttDHt", -"tuuDHutqDuttuuuuNOONDDHutqtuHuHHDDDCqqqqttqpmmmpqqqppCN0WUUXWLCNROOQOIuuttttttttuqpqttttttqqqqpmpmmllilqpmlpmlhmmpmlmpppqpmmmppmqjmqrqnmmmqqnmmmmmllllllmmllllllmnqnpnpqqpqtqpmqppmppopmppqpppppmpqmmmqummmqqtqqmmmpqqppppCCsppsDDuuDDIIHuuwDHIIIIDuuuuHODtDHtCN", -"qqtuvIutvuuuuuuIuPOIEIIEOwIOPOIPOOOutDHDODqqpppmptutmpmmlpqppmpplptqtqpppqqqqqpltqmlpmpmpmllqplmmllmppqqqpptwtqpqqtqqpqquuuttqtutppqtqttqqtqtqpmmquuqqmmillmmqqqlmmlimmqmpqqqqppqquqmmmpmqqqqqqqmmpqtpqtqqqqpmpqqlptutpmllpqqpllmppmmppmqqtqqqqqpqqqqtqtuutpqtuq", -"mpqqqqqqlpquuqmlmprqqqqpqqpttqttDDDttDDDOODDuDDDuHIutqppppqtppqqpDODtqqtmppqtDDDutqqqqppqtpputqutuutqtuuIuwIIIwIuwuuuuuwuwxuuuuuuuquutquuttuuxutqqqqmliilmmllilmlmmllmmmpmmllmmmmpnmmmmmmmqmmmmillmmmmmqqpqqmmmqIqmpqpmqtqpqpqqttuuttuuuqqqqpmpmqttqqqqmmpmmqqtq", -"mpmplmptqqqtqqpqmmqmpmpmpqqppqttmppmpqqqqpppqqttIIIDDHIuDHIIHIORtLOHCtCDtDDCDNNDIIHIHDuuIIEIIutwqtqqpmptqqmpmmptpmmmpqqpmmppmmlmliillilhmlllmpmmmmmmmqpqiliiiiiiqpmmpqpmqqmmmmqqqmppmqqqmqqqqqqqmlmpppqtqqpmplmppllpqpmlqpmmmmqtmmpmmqqpqqqqmpmpmqmpppmhlmqpmpqp", -"tqqpmmqqqqmpqppquuqpmqqqqttpqtuqpqqqqqtqpmmpqtqqqpqqtqtutuDDuDHODtqqDODqLHDuCDDtqtqtqtqquttqqplmmmpmllmpqpmlhklmppllmmpmmpqtqqppqpqttutuppmmmmmmpmmmquuuqqqqpqqtuxExEIuutuuuuutqrqqruuuuuuuuuvIIqtqtruuuvuuuuuuuqqquIutqtqttuttupqpmppmpmlmmmmmmqqppmqmlmpqqpqmq", -"uqqpqpqplmpuqqmmuqqqqqqtmqqppqtpqpqqqqpqqqqqpmppqqtqpmqqppmpmpqqpplltCqppppmpqtplmpppmpppplltqmppqqqmmquqqpmpqqqtqmpqqpmllmmpmlimmpnqqqmqquqqqtuqtqqqqqqqqqmmmmmquuutuuuqqtuutqpqqqqqqrqurqqqqqqqqtuutuqttqtqtqqHuqqqqtttqtuHuttuqqtqqqqqqqpqqqqtqqqqqqplmmpmqtu", -"qpmmmmmlqpqquqqqqqruuuuuptuuuutqqqpqqpppqqppmmllqtDuqpqDqqpppmppmpqplmplllllppqppqqqttqquqmpttpqmqqpmpqtmmllmppmqpmppmmltqttutqqqqqqqqqmillmlmpqqnmmmmliillmillllpqqpmqmpmpmmmmmllllllmmmliiliillmmpqqmliililllillllllmmqqpqppqquuqqqpmpqpqqpqpmmpmmmpmmlllmpmqt", -"qmllllllqmllillqmqquuquuwuDIIHDHDDDHDDuDDDDDtqtummpqpmqCmmmmmmmmmpqppmppppqppqpmppppqqqpttmlpmlmmmmmmmqqpqtqqqqpqtqtqtqpqqpmpppmqqqqqqmlliiilmmlilililmmlmmpqqqqqqtqqqtqmmllilllhiiiihilihhiilililmlmmmhllmlmqqmhlmpttppuqqpqpqtuqqqqmmpihhehhhhhlllhhlhmllmpmmm", -"pqmliimmqppnplilmmmmmlmutqqttqqutqqtqqqtuDDuCuDOODDLDCqDqqqtqtqqppppqDtpmpppqtqputqqttqpuuqqtqqututqtqtuqvIutqtqqtuuuqtqxurttrttqturqurqqmllmmieihiihilpmmqqmmmmmpmlmmlilllilhiiiimmilmpqmllmiiimppmpqpmimllpqpmppmllmqqpplmmlllmlillhhiliillmllimqpmlllihimqpmm", -"qqqpmpmpmmppmpqqqqqmllquqppqppqppppmppmpumpDDpmqDLOMDDDNDDDLLDDDDHEHHLOOuDDDIONDuuuuuuuwtuttqqpqqqqqrtrqpmmpmqmmqpmqtuqmpqttqmmmmiilmiiiiimiiiiilmmlmmpnmmmmlihlplilmllhhillpmmlmmmpqqmmqqnpqplmtuqqqtqppmpmpmmmpmompppmlhillhlmillillpqmlmmpmlilmpmqqmmqlmtupmq", -"uutqtqtqttrtqqqtnqqmilmqllpplpqqlmmmlilhpmmtqllqpqqqqqqqCqqqtqpqqCDDDDCDCttCDLuppppmmppqmpmpmllliiiiilmmmqqqmiihlhilmpmllmmlhhhlmmiiiihimmmmpnqqmqqmpqqqqpqqqmnqqqpqttpmpmpppppppqqqqqqtquqquqqqqtuttuuquuuqtqqpqtqtqqttpppmpmptqqqqqqqumpqqqpppmmllmqtumlmqqpqt", -"pmpmmmmmnqpmmmmqpmqqpmuwmmtqmputmpqtqqpqmmmpmlmpmpmppmpmqpmpmlmmppqttqqpmpmlmpmkmmmlllmpmmlllllhmmiiiihiilpmlihilllmpppmllliilpqqmlilllmlmmqnqqqqqrtquuqqqqrqqquwuuuxuutuuurtrttqquqqquuuuuuuuququvuuuuuutqqqqqqllpppquItqqqpppqqqqpnppqpqtqmlmmtpmlmmpqutqpmmqq", -"qtqqqqppppmmppqqmqmmmpqumpqplptllmpqqppqpppmmppmpmmpmppmpmmpmlmplmpppppmppppppmlmppmlllmplllllllmliihiihimnqmmmmlmmpmmmmpmpmpqtuuqnqqqnqqqruuqqqllmlmmmmlilmlilmmmppmpmmmpmmlmpnlmmmlilmqtqqqqmqpqtqqpqqlllmlmpqmmpmpqtuuuttqqtuuuuuuuuuuuuuutqtuutqtqqquIuqptuu", -"qtquturuuuutuuvxuurqqqqutuuqpuupqqqqpmmmtqqmpqqlpmlmppmlmmomplppppppmppppqqqqtppmmppmmmlppmmpmmmqnmmqqqqqqqqqqqnqttqqpppqqqqpmmmuqqrrqqnmqurqqmmiiilmqqmqqqqmlmplllillllpmlllllpmpqpmlilmmmlmlilillilmliiilllmpqppllmmlipllmmlpqtqtqtutumpqqquuuuquuuutuquuqquuu", -"iillmmpqqqpmpqpqqrtqqquuDutttIIqututttuuDDttuDtpqttqtqtqppqqqpqtqqqqppqqpqtttttqtttttttqtuttqtttvuqqqrqnqmnpqqqpqtqqpmmmllmpppmlmjmmmmiiiimmmiiemmpquvxuuuquqqqrtqpppqqttuuqqpqqqquuuqqpmqmmqmlmlmlmptqpllmmlmmqplhilplhllikhhhhihiillmlmlillilitmlmmlmmlmpmpqpl", -"hlillmpqlliililiilililmpmhlllmplmllmqqqqqtqqtqqqttttttttpqtttqqtqtCtttttDNONMOOHuuuutttutuuttqtuuniiiiiiiimmmmmnmllihhhhhilmmmpmihiiiheemmmmmmmmlmmmpqqmliiliilmplilmppmmpqpmlllmmmppmmmqtqpqqmqpqqqqrtqmmppmmppqqptuuttqtqtqpmqppllmmmmtqqpmlllqlillhhilmlmpmid", -"mmmmmpmqpmmpqqqpqqmmliiilhlllllmlilmqqplhilplhlmlmppmlmmpqtuqpptqCDDDDCtpqtqtqqptqpmlmpqmpqpmlqtrmiiiqqqlmqqmmmmtqpmmpmmppmlllllnmmmmmlmnmmmiimmqqpmnqmiihlillmqmlllmpmllmpqpmlmmlmmnppmqqqmqlillmmllllipqtqqpqqqpqqqppmllpttuuIuuqqpqqpqtqqmmqqqmpuupmmqmpquupm", -"mppppmppmpqqqqpqmpqtqttqqpmlllmpppllkhhhlmlllilllhhhillqhhllpmmphiimqqqqjmqqnnmnmmllmmmpmpnmmpqqmmqqqmmqnnqvvunqqqquuqtqqqqqqququtqqqpmqllhimmihhimmpmmlheeeheilmilmmhehmmmmmlliiiiiliiiihiiimliimmmmmmmimmmmmppqqqqpmlmlmmlmlmmlmppmpmmqppmppppmmpmlimmppmmpqqq", -"ppqqttuuttttppmppqqtqtttqqpqqpppuqqpqpmlllmllllmplhilllpplhihllqmmlliiieimnnqmnqmmmqqqqiqutqqqqqqqrrqqqqqqruuqqntqqqqqquqtqmqqqpqmpqqmlmpmmpttqmpqqqquuqqmmmmpqqqqqquqpqqqqqqmmimmmmmnmmmjlimiieiiiiimmmlilliiihhehiiehhihiihiklhhilllhlhhhhllmlmpqmlillmmlliiih", -"hilliihllmlllikidhhhhhilllmlpmmllllmmppmppppmppqpmlllillilllplmpqpmmlimmmmqqmmmnqqqqtqqqtqqqquqmqmqqnmmnqmmmmmmmmmmlihimmmmliiihillpmlhhillmmqqpnqqqqqqqqqqqqquuqmpqqqqquuuuuuqtqqqqqqqnqqqrqqqqqqqmnqqrqqmqppqqqmqqqpmqhihhikiilllllllihilllllihhiheddeiimlmlli", -"lllllllhihlihhllihlllillehhlihhhhhhllmmpmmmmllmlmpmmpmpmpppqqppmqqqqqqruqurnqmnnmmmlimmmmqmmmqmliiiiiiimmmmjmmmnqqqmmmmqmpmmilihilmppmlihillmpmpmpqmmqqqhiihehimpmmpmmmqrqqmmqqummjmmmmlmmnqqnnqqnmmpnnpmpnpmpqqqtrutqqqqqqqtqqttqqqppmlpplmmllhlmmpmmmmllmmppqq", -"mpmpqqqttuqtqqqqhililhhhmlmlllllmlihikihihhhhhhhhlmpmptuIuqplilmpqtqqmpqqqqmmmmlilqqqqmlmmlmmqmiiheiiilmhiihiiilmmmmllmmmmqmlmlipqqqqqqmpqqqqqqqmqqtuqqmqtqqmquuqmpmqmpqtqqqqqqqmmmmmmmmmqqmmllmmiimmqmmqqpmmlllmimqqnqqqqmqqqtqqqtqqqpmqqqqttuuqqqqqqqqmmpmnmqm", -"pmpmmppmqqtqqqtttqttuuqpqtqqqqqqmmlllmmmpllllilihlmllimpmmliihhiiiliiheeililiiiimmqqqqpqlmllmmmlmmmmqqnqqruruuurqqqqqrtquuvuquuuqqqqqqqqmqqqmmmmmqqqqqqmlnpiilmpqmnpmqqqqtrtqqqmuuqqqtqqqqqqqnmmnqqqqqqqqqqpmpmpnqqqqqqqpmmmqqqpmmppqqpqihhhilllmmmmllllmmmmpqqq", -"qqmpmpmmlmmqppnqqmlmqqpmqqqqqqqtqqqquuxwqqmpqqqqmmlilmmmhhimmlilhlilmlliljlilllilmliilmqmmmmmmmmqmmqqqqnimmmmnmlmmmmmqqmillihilmmpqppqpmlmlmmmllmmqqqqqpmtrpmntrmppmmmmmlmmmmllimmmmmmmiiiimmmmmmmnnmjliillmmmpmqnpnmlmpqqqqquurppnqpqqpuutqqqqqqqpmmmmmllmqqqqq", -"mlllmmpmqqtqqqppqmlmquqmmlmpmpppllmpqqqqmmlmpqqqppmmtxIuutqppmqtqqqqtqqpqqnqqnmmqquuuuuuqutqmpqmmmmnnmjmmmqnquurqpmmpqqmmqqmmmqqmqqqnqmlqmqqqtqqqtqqqqrqtvxqqtuvtrqqqqqmnmmmmmqtmmiiiiiimliiiiheiimmmmmmppmpppmlmmmmmlmqmlilmqpmqqqqqnpmqpnppmliqmmmmmqqmmqqqpmm", -"uqqqqmmmmmmmihimqmpqqtqqqqqqqqqrqutqmqqtqqqqqmllqqpmmmqqqqmmmpmmmmqqrqmlillmmmmmmmpqqqqmmljmqqmimmmmlimmmmnpnmnmmqqmmpqqmqnqmmmmlmmlmllmiiilmmmmqqqqmmiililqqqqqmqqqqqpqpmlilmpnmmmmlmmplmmlhilnlnqqqqqqpnpqppppqqqqqqqqqqqqqqqqqtqqqqpqmqqqqqmmuqmmmmqnmliiiiqu", -"uuqquqqtqqqqpmpqmmmmmqmpqqtqqqqqqqqqqqtqqqnpmmmmqqqqtuuutqqqqqqpqpqqqqqmpqqqqqppqqqqqmmmmmliliihimmmmimmmmmmmmmmmqnmmmmmmmmmmmlmmlmmmmmmmmmmpmpmmmmmlmmmilimqpmpmmmlmmmqnpmmpqnppqqqqtqqmmmqqutqnqqqqqtqpqqqtqmlmmjmnqnnqqnmmnpqmmmmmmnpmmqquuuuruqqqqmmqmqnqqrx", -"qpmqqqqqqtuuuqqquuqtuuuuvxuurtququtquuuqnppmqpqpqqpqqqqqqqqqqqqprrruuurqqqqtqqqquqqqmmmmqmliiliimmqqmmiiijijmmmmnqpmmqqqmqqqqmmmmnmmmmqqmqpnqnqqqqmmmqqqmmqqqqqqutqqqquutqqtrutqnpqruuqmqpqqurqmqqqqmqqpmmpppmllnnpnqqpmmmliliiimmppqqqqqqqqquuuqqqqqnpmmmmqqmqr", -"lilmmpmmqqqqqqqtqqqqquuuqqqqqqqqqqnqtuutqqqqqqqqvurqqutqqqqqqqqqutqqqqqququuutttqqqmpmpmqqmlmmppnqurqqmmmmpmmmmmqqnnqtrqnqqqqqmmpmmmmpnqpmmpmpmqqqqmquqpmmpqqmqqmmmmmpmpnqmqqqqqmmmpqqmlmqqmihlqmqpmmmmmppllllmpqqqqqnmmutrtrquuqqqqqqqqqqqqqpmmmmqqmmqqpmmmmilm", -"qqqqtrqqmmmqqmqrqqnqqqquqpqqqmqnqmmmqqqnuqqqqqqquuqmpmnpqqqqmqqqqqmmjmlmlmmmpmpmqqqqqqpqpmmppmqmmqnqqnqqnqmnmmmqnmmmmnnnmmnnmiifiliiimmmnqmnmmmmpmmmpqmlehiiiiilllmmlliiihiiimmmmlllmmihlmmihhquurqqqqtquqqpmpppnnmmmiihiiiiilmlnqpnpmmmqqqqqnqqqqqqqrruqqqqmmqq", -"rurqqtqqqmmmmmqqquqqqqqqqqrqqqqpqmmmmmllmmmmlimlmihheiimmmmmmlmnqnmliliiillmmmmpmqqnpmmmmmmmmliiiiiimmmnmmmimljljifiiihimmnmjifemmimlimmqnmmliiihiilmmmhehhilhimmmpqqqmmllilmpqqqpmmpmmlmmmmpqquuuuqquuuttttqqpppmmmmmmjmmmmmnqqqqqqqqqqqqqqqpmmnnqrruqnqnmnqqru", -"pqqmmnqmqmmmmmmmqqqmliiiimmqmmliqmqqqmimiliiiiiiilmmimpqmmmmmmmmqqnqnnmmqqqtttttqqqpmmmmmpqpmihhhehiiimliiiiiiimmjijjijmnqrqnnmmqqqqqqqqqqmmlilihlmmpqmmpmmmqqmqmqmqmpmmqqqqqqqqpnqqqqpmqqqpnqqpnqpmqqqpmqpqpollqqqmnqnqmmmmpqqqpnmqqqqqpnqqqmliljlmqqmmmliljmmq", -"mmmmmqqqqmliihiimmmmmiiiimpqqqmmilmqqmlmmmmmpmmmiimmlmqqqqtqqqqqqnqqqqqmmmmqmpmmuqqqqqttqqqqqmliiiiiiiieliiiimmmnnqrqqrvurvurrrrqrrrrrrqqqqqnqqqqquuuuuqrqqqqqqqqqqqqqqqmmmqqqqmmmppnpmpimpmihlqlliiimlimlllllomqnmjmlmmiiiiiiimiilililmmmqqqmmimieimnqmmiiiiiii", -"qnmmqqqnmmmmmmlitqmmmmmlmmmqqnqqqqqqmnqqqmqqqqqqqqqqqqquqtqqpppptqpllllhqqqlhehlmmmmmmmmmmmmmlmpjmmmilmqqnqqqqqqqqpmmmqqqqqqpmllmnmmqqpmqpnqrururtqqqqpqmiiilmmquqqmlillppmmlllliiiimmmmhihehiiljjmimiimmmnmmijmjiiiimnmnmiiijiimmmmmmqnqqmmmpmlmlhimqpmmmppmmmm", -"qnpmnmmmqqqqqnqnrqqquuurqurrqqqnuurrqqqqxJuqnmmiqqqqqmqqmmppmlmlmmmlmmpmllmllmqqxuuuuuqqqqqpmlmmmnmmiijmiiiimmmmmmmmlmmmlmmpmmmmjmmmnqqpqnqqqqrrqquqqqmmpmllihiilliillilnqqqmmllillmqqqmmmmmmpqqmnnqnqqrqqurqqmqmiijmnnnnmiijmjimjmjmmmqmmmppqqtqpmpqqqquuuuqqtq", -"npnqqqqnqrrqmmmmqqqqqqqqmmmqqqqqnqqqqmmmmqqmmtrqmijnqqqqmpmppmpmhlmlmpqpqtqppqtqqlimqqmlqnqmmillmmmliihiiiimmmmilmlmlllmmmmmmlmljmmmpqqpmmmljmmmmnqqqpmmqmmmmllmqqqpnqpmlmqqqmmllmmpqqqpuuuuuuuuvuvruruvqruurqqqmnnqqrqqqnnmnmmjmmmqmnpmqqtqnpqtqmmmmqqmpmmmmmmm", -"mmmmmmnqmnqnieiiiiiiiiilnmmliiiiiimmmmmmmnmiimqmihipquuuqqtuttqtqtuuuwEHEuuqqqplihhimmmmilihhhhemmmmnqnmmmmiijiimmmmmlillmllliilmmmmmqmmmlmiiljjqqmmmqqrqqqqqnqqpmmmpmmllmpqqqqqnqqqqnpmnpqqqqmmuvvrrqqnqruurqqqnnmnnnnnnqnnqqnmmnmnmmmlmqnpmmlmiiehilihmlllmpml", -"iiieeehemmpmiheihiiiilmqqqmmliilmmqqqqmmqpmmmlmmqmnruurqqtuuutqtquutquDEttqpqqqmpmmpmllmmpmlimmliimmqqmmmmiiiliippqmmlliliiiilmmmnmmmmpmmpqqnmmnurqqqqruqnqqnmmnmmmppqpmmpqqtqtuqtqqqpqqpqqqqmmlnqqqmmjlmmmmmmmmmliihhiimmmmmmmliilllihheeghllllihhhhilililmppml", -"miiiilmmnqqqnmmqqqpqpqqqmmmmqqtqqtuqqqqpnmpqqmquqnpquqqqmqpqpppmmpmmmmqqqqmmpqqqqqqnmiimmmmiilliqqqrqqnmqnmmmnqqqqqqqmmmmmmmmpmqnqmmqqqpmqqqqnmmqqqnqnqmqmmnqmmqutqqquqqmmpmmpqqmmmmmmmqmqmqmqmmmmnqqqqqnmmmljmmmjiheeehiiiiiiiihiijmmiiliilqqtppmmmppqpmmmpmmli", -"mqqqqruvqqrqqqqnuqqqqqmmpqpmmmmmqqqqmmmmquqqmllmiiimmmmmllllllllmmmmpqtqqqpmmpqmqqqqqmpquuuqtuvtvvxvuruuqqqqqqqqnnqqqqqqqqpmqmmmmmmmmnpplmqmmliiiilmmmjmmmmmmmmqpmmmqmlhhiiliiillmmmmlmliiiiilmmmnqqqruuuurururummmmiiiliiillilimmmpmmpmqqqtqttqqqppnqqqqttqqqqq", -"qruuuqqqquqqmmmllimqqrqmlimmmmmpmjliiillimpieiieiiimliiliillllmpilllmqmmllliimmpmlillliiimlhiqqmmmqqmmmmmjmmmmihillljlmmliiilmlliiihhihhmpmlieeiiiiiimmqqqmmliiiihilpmmhehhhihiimmqqpmlilillmpqqqqnmmmnqnmpmmpmmmmqmmlmmmmmmmmmnqqpqqqpmlmpppmppmmmmllmmqqqqmpqq", -"mqqqmqrwqqpmpmmmhhhimlllhmlilmlmqlhhhiiilpqpllllnqqqqqqptqqqqppqqpmmmmmpmmqqpmmmmmmmqqqqmlmmmmmmmqnqmmiimmqmjeeihiiiiiiimiiiiiiieihihhlmlmpmllmnqrqmmqqnmmmiiiihimmmmqmimmmqqmmpmppmmmqqqmququutnqqnpnqqmmqmmlmlpmllqqmihhililihliiiilihlllpmllplllllilmpqqpmpmp", -"qqpnqpqqqnqqqpmmmmmlmmmlqqqmmpqqqqmmmlmlmqqqquuquruqquuvqqtttqtuuuuqtqqqqtqqqqtrxuuxvuuuxuqqqqqqruuruqrqqqrqmmmjieiiiiiiimlmmmmnqqqqqqqutuuuqqqqqqqqqrqqnqnmqqqqmquqtuuqqqquqqquqqqtqqpmqmmqmqqmmmmqqmmmmmmmlmmqllililihiliililihlllmmppplmqspllmmpqqpmpmpqppqqq", -"qmllqqmmmpmqqqpmqtqppqpmqutmppmqqtuwuttupmllmqqquurqquvIqppqqpqtqqqqqqqqqnqmqqqqmqqqqqqmuqqmmqqqqqrrqqqrnqnmmmmmmmjlimmmmmmmmqqqnnqnmmqqqqqqqnmjmmmnrurmmmmmnqqnqqqqqqqqmmllmlmqqqmjlmmmqmpmmmmilimmqqmihihhhimmmmmpmmlmmliiiliihlmmlppqppoqtqplllmppmlmlmpmmpmp", -"pmlmqqplpmpmppmppqtmmtqplqplpmlllmpqqtqqqplllppmmmiiimpqqqmlkilpiilmmmmmilmqqmmillmmqqpmqmihilmmmmmmmijmiihiiliimmmiilijljmmjmmmimjmllmplliiiiieiiimmqmiiiiilmmmlmmmiliillljllmmqmhehilmpmmqlilhiiimmmliliihihiliilmmpmmqmmlmmmmmqtqpqtqttttutspqqpmmmqtpqqppmpm", -"qqppqqpmmmllmmmmmqpmlqpipqmllmlmlllmpqqphiihhhlimmmiimmmqqmlihhlilmmmmmlmmqqnpmlimmmqqnpqmliiihhjmmiiiiihiiiijiimiieffiiiiiiiiifhfhieilmqmmiiiiiihhilmiimmqqmmmmnpqpmmiheeehehiiilmqqqmlmmtqmilmiillmqmlqpppmppmmmmpqqqquuqqtuuutDEDtttuHDHDGCDCDDutqtDIDDuDutuu", -"DDuDuDttutqpqqtqqttqqqplttmhlmlptqmpqqqpqttqpqppnqqqqqpmlmppplhhmmmmmmiimmmlmjmmlilmmmmlmliiilihiijljlmmmmmmmliiiieieiiiiijljmjmimmmlmmquutqnmnqqqmqnpqqqquuqqquuruvuqmmqqqqqrtqmpqquuuqpqvxqpqqqqnqtuqquqtuuuttuutruxuuuuutruuuquDtqtttCCDtptCtqtDDuDCqHDCDLDLH", -"NDCCDDDCLDCtCDCCuDuuuuutuuqmpqqqqpmllpmmpmliilihmnqnpmmllmpqqpmpqqqqmmmlmmmmmpnqqqqqtqtqmlillmmmmmmnqnmqnqqqmmmmnnmmmmmnmmnnnqqnrqrrqquEuuuqqqnquqquqqqrqqquuqqqutquuqqqmqqqqqqqqqqqqquvqquuqruuqqqtruuuqqqqqqqqqqmpmqqtqquqqpqqpqqpppplpppopppplmqpmpqmzqqtDttq", -"pmlmqCDCztqqCtCqHuuDHDDIqDuuIIutututtqttuuqqtIIuuvxvvxurutqtttuIuuuuuuqqruuvxvxvququvxvxurqmqqqqqquurqqqqrrqnqruuurqnnnnmmnnqqnnijmiillmmqqqnnqrmmqqmlmpuqmqqqmlqmnqqqmqqqqqmqqqqquqqqqqqmmqmqqpilmmpmmmtqmlmpppmmqmmmquqquuqmmqqtpppppllpolpsplmqqmmpqpqpmpqpmm", -"llmppqpmqqqqqqqpruqqquupptttpppppmquuupmptuuuutqDDtqppppuuIurruquuuurqqquuuuqtqquuuuuuuEvqmmqqqmqqtqppnqqqqqqmmmqnieeimmmmmlmjiiiljmmmqtqplhllpluqpmmmpmmqqpmmmpmppqpppqhmtqqpmmpmlpqpmhpmpppppqpqqppppmtqllpuqpnrrunmmqrtqqtpplqtqpmmmlpquqpmppqpllmpqqtqpqqDtq", -"qqtqqpqpppppqppqqtuqqqqqqqqpppqupmlppmllqmlllmpqpppmmmlmimqqppnqmmqmpmmmmqnmmmpmqnqnnnqqqmmilmmmlmppmlihjiimjiiimmmiilmqqnnqnqmiiimllmmqqqqppqtqqqqpmpnpmqqmlmpqlmllmpmpqqqtqppmmpmppppmlppmmlmpppliipqtqqplmqpljnnrqnqrmmlppppptutttuuttuutqtqqttDuDtqpqpmmqqqm", -"qtqpmmmqtrtqqtqqquvuqqtuppmlmppqqppqqqpputpllpqqpmpmpmpmhlpqnqqpmmmmmmqqmmpmmmqmmmmmlmmmmmmmjlimhilmmmmlmlmmmmjmiiiiimmmmmnqqnmmlmjmmmmpmmlllpmllmmmmllmmmpmmmnppmllpppmppplmmllllmpmmmpmpqpplmmpmlhhlpqllllmppmrrrvvvuItututtuDuHEuuuHuuHuuIOIDOOHMDOEHDDttDDtq", -"DDHDutDOqqqppmppmqqqmlmqppmpsqplllpqtqpmtpmpqpplqqqpppmpmqqqqqqqmmppmqqtmqqqqqqqnmnnmmmmmmmmmmmmllmpquqqmilmmiilmmmllmmljmpqnpnmnnqqqqqqqtqqpqqpqpmmpqnpqtqtqttqutpqqutqppmmppppmppqqqttttttqtqtwvwwuuuutttqtuuuEvvEEuuEuuDutuDHHEwututqtttuDIHuDDqqtqCtDutDIOOD", -"qtutqDIOOOOODHOOPOPIPIIIuutuuHutppqtutppqqqtutmltqpmmmpqppqqpqqqpqqmqpqqqqqqmqqqqtqqqqqqmmmqqqmlmmjjmmlimmmqpmlmqtqpnqqqqqqqqnqqqqurtruuuvutqtutEuqtuvwuuuuvIvuqtquuututquuutqtuuutuuwuuutqtuuttuuDIIutquuqqpppqqnqqnmmqlmpmlpttpqtqtqqpqquuuqpppppqpmlhlllpqtuu", -"lmmmlpqttttqqqDNIvtuEDutOuuuIOOOIHDuDuuDHDHEIIHutttqtuuDtutquuvuuuuuuuuuuuuuuuuxEEvurqqrqqpqqqqmvvuuruvvuuuuuutuqqqmpqqquuqqqqqqmnqqnpqqqtpmlmmmuqmmqtqqpmqtqqpmlppppmmmpqttqpmptqpppqqpqpmmpqpmlllmpmmpqmlllillmmnqnmqunqqpmqtpqtttqtqpqtDIHuDItquuHIDIutqqtqpp", -"qtqqqquDDDDtqtDOEutuuutqutttuHIOHuttqpqtttttttutDDDHDHDDtuuuuIIIDEIEvuuDuIuuuEIIuuuutqtqqqqmqqqqmmnmmmqqqqqqtqpqllmllmppuqqqqpmmmmmmmmmmqtqpmpppmmmmmmmmllmmpmmpmmllmomllmpmmlllmmmlllmpmpppmlmmpppqtttttppqtqtqqqqruruIuIuttHuttuutuuuuuuHIOIOXOIHDIWY2WPOHuttq", -"ttqttDDDuDtqpmqtuqqqtpmpqqqtttttqpqttpppmpptpqttqqtCtqpmpqqqquqqqtqtqqqqmmpmmqqqmmmmmmmqmmmmlimqnnrqnnmqillpmompillllmmlqqpqqqqpruqqpmqqqqtqtqqpqtuutqtqqqquuquIutqqtuttqqqqttutqttqpptutuxuqpqutquIIutuutquutqpuqqqqqqqqqtqtEItqtttuOWXHutqqqtDtqtuuDwtuutqtuuH", -"qqtuuqtqDtuDDDDODDEHDttutttptDtptpptqptOQHuqtpmllpqlpV0QuqqtqpmpqqpmllmpmquutqpqqmmmmmmmllllmplhmmjiiiimillmpptttqqpmppqmpmquuqqqrrruuuuuwuuuuttqquuDuuuuuuuuuIEHuuuHEwuItptuutuIIuuuuuuIuutuwutqtqqtqqtquqpputqrqnqqmmqqtqmquupqqquORIuqpmpppppptuDIItppqqtqppp", -"qtqtDtDutqDDDtppuuuDDuDIIOOHOWXHtttHIDOY0VONDCtqtLOODHDutqqqqppqlmpmppqtutpmmmpmmmmppqpmqqqqtqmlnnnnmmmnmmmlmpmptutqqqqqqqtqqpmmqmmmmmpqqqqtuutquqmmmpqtipqqtrqqlpqtppqutqqtqpmpllllpqttqtuqpmtutqtpppqqtIIupquwqqpqqpnquvtpptuuupmlptDumpqpqqqquuttuDtmmppqtuuq", -"qqqquDHODqtqqquEttqqttqtDHHHNXODODNUUHHOHNHHNHDGLQYYXNCDODDHDuuItuuHIIOROIDHHIDuwDwEIIwutttuuuutvuurqqqqqqmpppqmlmmmlliimqqqmmmpmmmmmqqqqqqqpqqpqqpqquqmmmqqmplipqutqpqumqtqppqtutqqppmpqqppqtqqqtqqmptuptuqlmpmpmqqqqpqtwJIuuuwuwDxDuDHquIDuIIHuDuHOPHttqqtHIut", -"qqttCDDDDtqtqtOYuqpqqqpppttttHHsONNOHtqsqtqpqCCCppCNCtqqtqtDutqututuuuDDtuuDIDtpqqqqpqpmqqtttttuvvrrqrrqrqpmmpmlllmmmmmplmmmmmmmnqmmpqqqtqpllmppiipuuuqlqqqmmmpputpmmplhlpplipuuililmqqqlllptqlhlmmmlmpquutqttqmqpppqqqqtuPQPuuumtIOIuuuuDIHutuupquIIHuqttpqutqp", -"DIODuDtqtDEOHDqtDtqqtuCDptDDDNNCCtCCCCtCNHCppqtpCNONOYWDqtuDDqqqtqqpmpppqmpmmpmpqtpmmpqpqqqpmlmlpmmmqqqquqmlmiihjllllmmnmmliiiiiqmmiiliillillmpqhiiillmmhiihilmqupmllllipqmhhllltppllhhhlpuuqplmpqttqqqtuuutuwupqqqqqtuuqqpqqmmttttqpqHOIHuIuqtItuIOIutttttuuHuw", -"uDODDODtODOOODDuDDuDDDDHtNNNNOOHDDDDDNLDUUHttCDtlpppCNDpCDOOODuDDDtqttutqttttqpmliihhlmlppmllllmmllilmmlmmiimmmiiiheeehimiiimmmimiilmmmmlmpqtqppqpmlmmpqquIxuxuuqttqpqqtqppmmpmlmmpquwwuuuuttqttutuuttqqqttqqpqquuttuxIJIxvIxuvvuuqqptIXutqtqptDutwuttuIuuuwuuuu", -"mqtquDODODtDIOOODDDHDtDDDOOHNONNWUNNNNNGHONCLONNCCCCDNDCtCDODtDHDDuDDDDDuDDEODqmqttqtIIuqpppqttttqpmpmmimmmmmnnqmmmmmmmmmnmqnqqqnmmqqutqquuutqppqqtuuurtqqtqqqmmmpqtqpqtqppqttqqtttttqqptplmptqpqpmpppmltqqtqppqttuqtuIIuqtqqpmmpmommmpplpmllpqpmlllpmptpppmppll", -"lpplmtqpDtqDOECtqtDENDOQNUWONWWOUNOUOUNDNWUNNWUCYUNNLtCODDOOOEOVOOOOOVOOWODDOOOItIDuuOIDIutttuutuuqtuuuuqqqnmmmmnqqqqqqruuvurqrruuuruuqmpmplllmpmmlmqqqqquqqpquutqqtIwqlpllmpmptpqqqqtqqqqutqquxuqqquuuttpllpqmllmplmqtqIvumimpqpmllllmlmEHmpIIpqplpqpppqpmptttq", -"mmmmqqqmimmqmpmjlpqCDCqmDNDCLLNUUOUWUOOOOUVUOLOWONOMNLOUHDCtDHHtHuDHOIDtuuqtuuqqqqqppqppqmmpqqqquqqqpmpqtqqtqppqpmmlllmppqqttqqqutqtttttqqqttqqpmpqqpqtuqqtuutDDOEuqqmpqnqqqqqqqqqqtqqqqDtNOHtqoqlmqqtqmmpliplhtmlmptDDHtHtpsqttqptutmtutuuuqqqqtqppppqqpqqpmmmm", -"mqmmnqrqmmmimmmqlllppmpllpmptCzHCCqCCzCCCDDCqtzCDDCtmpppqtttDHDtqqpmppmlqtuqmilmqmliillitqpmqquuqpmqmlmmllmqtqtuutqqqttuqtutttttuuutuuuDtppmppppqqqqpmmlqmmmpmmlqpmpmllmppqpqpqqmmpmpmqqplpqplplmilmmqqplmqtuqpqtqqtuDHDtDtppppttpqtqptuqttqqppqqqqqmmpmmqqppqpl", -"pqpmppqqqppmlpqqlmpmqpqqlmpmzqCDDDCDDDDMLDDCCztqCLDCtqqtmppqtttpuuttpppqqqpmqqmiqmlhiilluqmlilmmmmpmmliimmpqqqqtqppmpqpppmppmppqmpqpllptqqplllllmppqqpmlppmpquqmqpmppmmpmmmmmmppmmmmlmppqmmpllppqmlmpquqttuHuuHDHIIOOOIOOQOtHHDHODuDuHOHIOOOHIHIOODDDuttqtuqqDtm", -"uuutqqqpllmlmllhpmpmpmppqCpptqqCCqqtzqCCLDCzCDCzpppqpqtCmppqttpppppmlmpqmiimpmlitqpmmlmmqpmhhilhmmmmllilpmpmplmmqmmompmlmppmpmpplmppmlpqppmppmlillimpqpmmihiptqpmmmpqmpqllllmpmmmmmmllmmtplpllllqqqqquIuutDIuHPIPVWVQOWXQYXOXWW0WRWQOWYRYWWWXUXWUWUXOOMOHVUMHOEq", -"DNINDttttDORQOutillmllilqqmlmpmtqpqqtppptqpqqqtqqqqqpppqtttttttqtuuuttuDuOXOuqqvttqtqpqpmpppqtqqpmmlmmmmmpmpppppqplmppllpmmlllmpppqqtqqpqpqtqpppqpmpqqqpqtpmpqqptqtttqqqpmmmppppqqqqmqpqtmqtqtuturuvuJOuutIWIDItHNONHNU0NWTNTWOWOUWUNOWOWONNHNGDOOPUOOODDXYQOOOH", -"HDNOOODDtDHOONHDtCDCtppppqmlptzNDCDLLCqCCzqtCDCCLNLDDDDCHODDtuCtqtttqqqtuIOIqmnquuuuutququuruxIuquqqquutquuuuuuuqqppqqpmqqppmppqtqttuwutIHuuuHIDIuuuuDuDIIIuuIIDPIDEuuuHIDuuuDutEIMIDuDDPDHUODNqpquvDIOuuuIDtuDtDDDDCDQWCONGHNNWNHNOHDNHUNNHDDHCHLHODDDDtLPODDOO", -"CttDNCCCNNNNNNONOUXUMODLqCttDLDODCCDDDCDLNDLLNLMCDCCLDDDDLHttuDtIOIDuuuuuuqquuuquuuuqqtutuqpqtuquuuqtuuuuxxuuuutwuwuuuIxHIIIuwvIIIuDIOIDIHDuwDIHuDDHDDHImtqqtDIuDttqpmpqOIDHEIDuEEDDDuDDODuDtqmlmmqtquupDHtmpqtDttGDDGDNNNHCGNNWUCGNNGNNWWNNNNNNLDLDDCCCCCCLDqCO", -"NtpCHCtCDCCCCtppDDNDCzCDCLDzDCqCOLLLNLOONDLDDDDDDDLDLLHDttCqtttttqqpppppmmqqnmnqmqppmmqqqqmiiqutqqqqqqqmpqqqqtqqqqtttuuHuuuuuuutDttpqtttpqptqqppqqtqqppmlmppqDtpIuqpmmpqppmmtqqpqmmmmmpqDqqDqqplimqqmqqipuqlppmtpqttttspGNCsCCGN1CCNNGNHNCCtGCGCDNDCCCqqODDLDtqD", -"DNUCppCUKspppCCpDpCDmtLpCqmlpqCDlpqptOOLDDCtzpplppCDNDtCqtpppllpmqpiilmmmmpmmmqqqmlmpqpqplllmmpqqqqiimqqpqplimtqmpqpmpqtutpmpppmpqpppqqqpmqqsppqpqttpmpqqplmlmpqqpqpppppmpppqttpmqqqmlmmqppppmllllmmqqtuqtuutqtuDOODsqLWDHNUWNNGCCGNNCCCsCCKCttCDOCzOMCCOzDOLqCz", -"pCCCCCCCpCUNpCLCDpqCpqDqmtNODCDLOUOCqCDCqqqpqpppmppqmpmmtpmtOQHtmpqtqqplpqqqqqqrtqqquqqpmllmpmmmqqqqppqqmmmlllmplmppmppqpmpppqqtmmmpmpppppqqqppqlmpmmlmpmmmppmpppppqpqqqtqqpmpmlmmqnmmmqmpqqqtqqurquuuuuqppqtutqHNLCtDONCCGNHNN0NKNOUNNTXTNNNKNWLLDDLtmCLtztCNDp", -"CCKNLNLNlCKLKNTpCqqCzpqCCDOLCqCNDOOzpqtzqpqqqpqqpqqppCDtqplpuOuppmlmppqqmmmmmmnmihillliimlllmmlmqmmqqqmppmpmppmmlllmpmmmlmmmppptppqpqtqqtqtttqttqqqqqqpppppqtqqqqqqqqqqtpqpmppplrurqqqqutrttqmlhmmllmmmmmllmpqqpqqqlmCCpqzCCppCWCCCKNNCNUNDGDNNUNCLUNqtLOUNzCNCm", -"NUNKCCLTNqCCDUTCDDCDDqmqOLqpqppmpLUOOOUNDCCqppqqpqqlpDDCtttpppqtutmpppquDuuuurqqtttuuuuxuuquuuuwqmpuuqqqqllqqpmpppqtqttptqtqqqqqtuttttttqpqqtttuwuutttqpqpqtutqttqtqtqtquuuuwEIInmmmmmmmmmqqttqqurqqqtttqquttqttDDCqqLDqmtDLpppLCCtCqppCCppCCCCpCmCUCCNLCUUCqzDN", -"ULCzqzCLZNLUKzCLUNDCLCtLNCqCDzmllpqqzCqmLDCDzpqCCLDqqNHqqHODqtHODDDIDqqqEDDDruqnmmqqqpqqmllmpmppmmquqpqupillpllmmmpqqqpmqplllppmtqqtqqppmlmpqqqqtqpqqpmlpmpqqqqtpppmmpmpqqpppmmpmqmmljmmpquuvHuuIvuuuqqqqtttqpqtAOMDrEDqCDLNDzDNOLLDDCDLCqCNOLCqllpCpzLpmsppqppZ", -"CplqNUCpLpzUNCLCUODztDUXDDLOLDDUDLNDNUODODCLHDCDDONLOUODptCttDttqtDqppmmmmmmqmnmlmpqtnllmmqtuqpmhhilihimqmmmmmpplmppppmpplilmpqpqttttqqptpqttqptppmpqqppmpmpqtquqqppqttuuutuqpptrqrqqqqquqqtqppmmmmmmpmmplilqtplmqqqmmmmqqqqqqqDDCDLDCLONDDDLDCDpCLqpCClCCllCplD", -"zqzLUULmmmpzLUMzCzCqpLULLCCDCCNVptCqqDLCOCqLOLCDpppqCDCtmpqpqtphqqpilqqmmqqtrqrupmmtqpmlpmmqqpmmhihhhehhpqqpppqqqqtutqtqttqttutqtqtuutqpttquutqqmmppqtqqpmpqtqtutqqtqtuupppmplmqmmmmnmmmililmpqtqqqqqtuutplpqtqmmmnqnmmmjlimllmqpmptqpqDCqqqqqCDCTUKLCzpTUCmKtlp", -"mDSULzpqhDYLlzNzllDDmDNlCpmDLtmllqDCqCqpLpmCDtmpDqqCDqpmpttqpttppttqDXIlqrDEDruEIuttuuuuIutqqqqtqqqmmqmmimplilmlhlmmllllmpqpmlhhlmpqpppmlllpqppllllmmpmpmlpqtqtqppplmmpppmmmlhlmmmmnqqqqpmmmmpqtqqnpmmmilmlllhhhjijqnlimlmqqmmlmmmpqpmpqmmpqqqDOlCLCNpoKq0LoCCpN", -"qmqqDOOOuMOIuqDICqpCOOCmDCqpCqplmqpmtqqMDqtuqpqHCCCDOOHuOMEDurDEqqqpqtqputqqqqquqrurqnqrqqqnqmmqmqnmuvtqpmqqqmimmmpnmlmqmmmppmllihimqqnmmmmmmmmmnmmnmnnqqqrtqmmqnmjmmmmnlmlllmpqqlmpmimlmlmmpmlmmquuqmmpqmmmpqmhjijimnnmnmmnnmmmlzmlmpDqllmqqlmmlllmmlmphlmmmpmm", -"mmmmmqqnqturqtuDDDCDNODCOMNLOODCHODDDttOIDOOOqDOONCqtDOOqtuqqpnmqqpmmpmlrqqqmlmqmmmmmmqrimmmqqnqimlhmmmliihmmmmmmjmmmmimpqpppmmlunmmnmiimmnmmmmmnnmnmmmnnnqqqmmmjjlmmmmilililmqqmilnmlmmqmmqqmmpqqqqqpmmmlmmqqmlmnnmnruuuruuqnmnqLplllmlqqqmmiiqqmlllmqDIDtmlmmm", -"mqpqpmmmmmqqtDMOmpmpmpmpztztCzqqqpqtqqqqpqCDDpptOODCtqCDqqmqqqpmmpqpqquqpmmqqquEqqqquqmmmnmmqqmmmqmiimmmmieimqqquqquqqqqmpqpmllpnpnqqqqqnqqqnnmqrqnnqnnquqqrqmilimjmmmmjlilmmpqppmptqqqqutuDutqqqqpmqqmmmmmpnpmimpmliiiijmnqmimqlCmpmptmqDDqmmpmllqDDtqqpqqttttq", -"qqqqmmmpllilmqqqpmpppqqpppqqppqqpmqHqqtpmpqDDqqqtCDCtqtDDqpmqqqqhilmmpqtmmmlmimmqnmmnmiemqmimmihmqlehihiqliilmmimjmmpmmmtrtqtqttnqrrqmiiiljmmmmmmmnqqnqqqqqqqqmlmmljmmmpqqqtuuuuqpquqqtpillmmlllqmhehlmlihhhhiedaeeeeiimdeiiiiiihllmqqDqlqDqpqqqpqqqtqqtpquDDDqq", -"qqqqpmpqqmmmmmmpqppqDLCqpqmpmmtCDptDqqqmqqqtDtqqpqqpmtMWODqmqqqmuuDtqpqqutqqqqqqIuqqquuuimpmqnmqimmimlimmlheiihedehjiilmhedhhhhhlmmmiheeddddddeeeeimmmliiheilmmpjiiiiimmimqqmlmplippmmpicdehhhhdlhddeehiiheiilllqqqiheedmlimmihehlhpplmhhqqpimmipmpqqpqqtqmpqqtD", -"mmmmmmmmppmpqqqqpmmpCDqpppplmpzLDqqqppqtCtqtqqpmttCtppqtpmpquuqmllllhedhihiiiimmiljmmmliiqqmmqqqmmpmqqmmliiilmmiimmqmiimliklmpmmimlieiileeeeeddeeeinqmilmilillmpijmmmmmmhlmlihhihhllklmlhlllppmmiiimmllihiehhiildhiilmqqqmmmpmihdlhmplpimtqlilmihlpttqmmplhillmm", -"hhhhhhhhihlillmmpmppqqppqqqpptDDDtmpqttEtDDtqpqqqqtqpliiilmqCDqmllilmlllrqmpmlilimquqmhehmlhiiheililmihhimmlmmqqmmmmlihiililllllurqiheieimmliiiiiimpqpmmqpqpmllmjmnnmmmmmqqtpmmqllllllplhllllpplpqqqrqmmhhhehehelmplillmmllpqpppmmlqDqDqtqqmmmmlmliiilpDDqmlkedc", -"qmmmppmmqqqqmmlllllihhilhhhhlllllmliqlelhlmlhhilmlihhilpmllmmmmlmllmqppqqpmqqqqqnqqmihimqunmmqmlimiimleeelmieimqiiimnqqqlmmpmlllmmmlmmmmiliiiiimlimqqnppmmmpmllpmmmmmimnlmmpmmmmllplllphllplmpppuqqqtqqmqqquEDuuDOEtppppqpqqtquDOOqDCqqlmmmpqqpmllllpllmUtlkilpq", -"qqppqqqmqDCpmqqpmmppppmmppmmllmtqppqpmmllillllllhilpqpqtqpptDDttquDIDuqqqquvuuqqpqqpmqqpuqppqqqmmlimmmilmmiimplhmimqqmmmqqpqppppnmmlmmmmpmmpmllilmqmqqpmmtqmlpplmmmnnmmilpqqmlmpllpppppqppqCCtqpmmmmpqmmlqqmqqqqmmlmmpqqDqtDDtqqODDqqqqqtCDDDDOODDDCqqtCCCLPODqt", -"OMDDMNDDOODuqqqqppqqDDtqqqtDDqtCDqqqqppqqppmqqqqmmpnpmmpqqqDODOOODCqqqqquqqqqqqqqqqqmpmlpmmmqqqqIuqpmllmuuqqqqniqmimmliiiillppqpmlilmmmlrpmmmlmqmqqqmlillllhhllhiiimmmieiihhhilphlpqzCCCpppqzpppihllmmliimpmmmilmlllllmmppqDDqplmpquLDDCqqqCqqCDCLDCqCCDMNDNLCDL", -"ONNLDLONLCCCDLDDDCDDLNLDNCCqqppqqutpqDDDOEDuqqqqqtqDutqqptDDqpqCuqmmppqtqqpmmqqqllllmpmlmpqqqqqtuqnqqnmqnqqmqqqqrqmmmmlmqppmmpmlmppqqqqqqqqqqqmpimqmiiiiquqpmpmhmmjmiiihliliilmmhhlmommmpmpppmmlhiimmllilqqmpmlmlmilmmmqmnquqqleilmqqqqmpmlmpmqCqCLCCDLLNLDCCCKO", -"qzDCCCzDCmpLUOLNUOLDCDLOLtmppqppqCqmpDODDHDtqppmmmqqqnpptDHCqppqDttpmlliiiilmljlllllpqplhilllklihilmqqqmmpnqquuurqqqqmqqqqqtuHIwDuDuDDutqquDuqqmquurqqtqqqqppqpmrqqnmmiipnppqpmlpmllhllpmlmllllllmpmihiimmmmqqlmiiimmmmmmmpimmmiiihhililmllllllmpCCCCCLNCCCLDCDL", -"ptDDCqCzDqCLULCztDDCmpqDppqNUOzpqDDpmqtmpqqqqpmpqnqqqpmlmmpppppqpqqqqpqqpqqqqqqnmllllmlhlllilihhiilmmmlilmmmlmmmmmmmmqqqqqquIIIDODDqqqqntqqppqqqqnnmmmmilmpnqquurqqnmmmmnppqqqlillihllmpmmlllilhnqqmihhlmmiimmhelilmiheeiiiiimqmmmpqqqtuLDDLCzqCmpzqpqCqzCLDCCCC", -"mpzzqqqtztqDDCpmlmCtpmpqCqtDLDqptDtqpqpmmpqtmmlmpmmqqqmmllllmpqpmppqtDIOEuuqqquuuuutuuuqqpppqqqpmmmmmmmlimliiiiheimmmmmmmqpqppppDDqpmlmlmmmlilllqqmmqqqmlmppmpqqmnnnmmnqpmmmpnpmmmmpnqpmtqqqqpmpqqqmlimmqpilqmihmiimjeeelmjlmmmmdhiillilmllmplllpqCpmompCDCppppp", -"pppqztzCqCCzCzCqpqzCCtzCODpppmmpqqqqqtqttqtqqppqjmlmqqqqtDDttHDtODtqqqqpqqmmmmmplmllllllllmmlllmqqqmmqqqmnqmqqqqmmnmmpnpehllmmquDuqqqqpmhlmmmmmhijjjmnmjmmiiihhhiimmmnqrqqqtuDuuEHvDIuuquuuturtqqqqpmmqquqqquqmqqmmnmjmnrnqnnmmjqrturqqtqqqCLLKLzCCCpqCCNLKzppzp", -"LDDDCLOUNUODCLOLOLDCDLNOCqzqCqtqDttttqtDmpqtqtEPIDuEEDDDqtCqpqtztpmptDqmmnqqurqquutplpmpmppllhlpmqqqquqmmmmmmmmjqruqmmmmmmmlllptuzutuuqquuqppqtrqrurqqqnpmmmmmmmimmnmqqrqrDOOOIDurqqqqqqqqqqqqqqqmqmmpmmmqmpqqqEErnnnmmqrqnqrqnuqqqpmqtDODzCCCzCCNLLCTUUNUWUNUUN", -"nDDmpDLDMMLDUOLUCNNLNUUCLKNUNLKNCNULUUULNCCCCppBOErqpqqqmuummqutOuqruuuuIuqqqtrtqrurrquvuEJuqnqqrrqrurqqnqnmmmmmppqpqqplpppppptDKCKKKKCCyyKCCByytqpppqttpppppppppppppmmpqqqqqmquvqqnnqqnnnmnqnmmmmmnqnmmmmnqqqqqmnqqqnmmlqtllllolqCqpliqpmpqzpllmmtqpqqCCDCpoqCC", -"mmmmmmpqztppCzpqplpCCCCyppsCCpqCpypppKCsplopypppmmmmqqqquEIttuDvEuuurqqqqqqquqqmimmmjjmmqruqnmqqmjmnqrrqvuuqnqquqqqqtuqpllmmlmptKLLLLSTSNTTTKByBqpmlllmppqtuDtttKLLCCqtztqqqqmqqruqqqnnnqmmmmmmjmmmmqmmiiljmmjiimjmmmnpplqppoppCqCqqqppCLCzCDCqqOMDDzqqqlmqCqplk", -"DrCDDqzDDCqzLDqCDCCLLpptCqCCCzCCzCCpCNLCCzqCCCzqDDDDDEDDDDutqqttqpqppllmlllmpplhmjmmmmmmmmmmljmiiiiimmmmqqrrqqnnqqqpqqqpuuutqqqqCKLLKCKKCKTKCyCKDCtqtttqqCDDHDDDMNLLDLDOqqmmqpmmnnqnqqqnrqnnnqnqmmmmmmmlmmmilllijijmmmqqpqppqspCLDCzDLDLVNDDLDLDDDCDDDCqDDNCCCCq", -"nqqqzqtzDLLNUOLOUONOKqqCLCCLLCCCHLDDNUUNLNLLDCCCUIDtqttqtqqpmllmilllillmlililmlljiiijmjimmjiiiifliiiimmmiimmnmmjlmmimmpmqtqqpmppzzCCppmppyyyyoyCtqqpqqtqttDCtqtqKKCzCqDDqpmpmmlmimmnnmnqqqnqqruruuuuuuuqqqpqpnmqmnqnpnpmqpmpColBDCpmCDCDNLCCqCqCmpmqqCDCDCqpptCC", -"immlmqmlmqqCDqpCpzzpmqCzqmpqqqnqqqqqzLDqqqCqmmpqpmlimmpqmmlmlillmliilmpmtqmllmmqiiiiliiililillihiiiilmmmqmiehjnqlmmmmpqqhmmmlmpmqqzpmllmCCpoooollllooolopppololpqqppmpqpmmpmliimilllilmmmiiimpmpllllhihlpmmmmpqqqqqqqnmlqplptmklqqmlpmpqCqqqpqppqqtqqppqllpqCqlk", -"muqmmqqihllmpllpmqqilmqmliimmppqilmmpmmlqqqlihiilimppqmplllllmpppmlhlpmlppmlllihmmmmmmmmiiihilliiihiiiiiqmiiiimmimmmmnqqmqtqmppmmpppppplypllomolppomplolplolllppppmmppqqmmpmliimmmmliillmllllmmlqqpmpmppmlllmpppnqqrqpmilmppqpklpCplpppCqCzqpqpmpqzqmlmpllpCCtol", -"nqqmmqmlmmllqplmmpqpmplimllmpmmqmmpqpmmmqzqpmpmlmmlmmllhlmmllpplmmlilmmlilllilhlimmmmiiliimliimlmljiiiiimjmlmiieijmlmmmqqqDpmmmhqpmmpqppplompppppolllllkppppppppqpmpqqppmpmpmlmmppmmomllqpmmpqpmpppplllmppppomlpmnnqqmmlippmppllqqpmpqqLpqCqpppmlmmpmmmpqmllllll", -"qmlmqmmmqqlmCqmlpimqDqlmmlilmmllpqqqmmmqilmmDMDqDqpmlllipttmmpmlmpqpmmpmllllmpqtmmqqmmmmqqqqmqqmmmmnqqqnmmmmmmliiiljimqmmuDqqtqqDqqtqCqmpqtppopppppppspqppqqppompmpmpqqmpmmqqpmppmpqzqpmmmmpqqqppqppllppppppmpolqqqqqppmiqplolllppllpqqCqCzpmmpmillmpqpqDqopppop", -"qnCEqllihlpCCplmqmlmqmmqtmmpqmmqimqqmmmmlnmlmpmmilmmppqqlmmppmptqquDttuqqpmplhmqqmmqmiiilmmqmmlllmmmpqqupqqqqqqqmqrqqqqrqqqqqmqqqpmqDOtmtHDplttplppppomoolloppmlqqqtrqqqqtDqqDDqppmomlmllptCCzppppllpplllpppplmpqpmqDDmllmqqqqqpmpqmpLLmDCqCqqqCuqmpqCqpqqpptDCp", -"ODDDqqztDzqDDDCCDDDLDqtDqqpqqpqqOqmlmpmmmpmmqqmlqqqqqqpputDEDqppplpqqtqppmlmllmtmiileelmmmmmlhhimmpqmlihiheeddeeeeiiijmmqqqqqqpnqqqqtDqplqCqpqplopppptCCCCCCCCGCDqqpqpmllmmlmpmmppqzCCCDqyzzCCCCDDqpCtppDCCCqpppqqDDqlllmpmmlmppqmllipCCqppppppzOOMDDqpmCppCCppt", -"AqqmlmCmDqppzqqqlqLCppmpzCCCCDCCOzqpmmDUqCqqLDqmpqqCqCqzqpllllmpmllpqzqlDCtDDtCDtqDODuDEuDHDuuuHruuuuqqqqqqmpmqqmnmmmmmnmmqqruqtquDuruDtDDutqtDDqtttqtDDqqtCtqtCEuqquDDqtDDtCDDCqCzCCzCzppllmppzlllhllilpmlpqCCtMDCDODDtqAttqDDDDpqtppzDCqqzDCDLqDDDqpmptmptCmpC", -"DDDzqDDqDDDOOLCCzNUNzCCCpzzqpCzpDCDqlhhqmqpmqpmmlllmppmpDqmlptHIODLUNOODCqqDCqmpmhlnpmmlhimllimpmpnqqqquqqquuuuururqqqmmeehmpqmmillillmmqpmmompttqqqpmppppppppqqqpmpqDDDqzCqqzCqppqpppmllllompmlpppptCsthhghllppmhhlqqmillmmpmmlplpzqqCzDCCDLDCDpqDDqqCDMNDLNHKO", -"DDMLDLMmzLUYUOLOKNTNLNNTNUYWTUYUUNLUUNDLCUUUNLNNVUOUULHDDCDHODDtllqqmmpmpllpplilqlillmpmlmpqmllmlmlihillhhllmmmmqnqqrqqqmpnqqqpmiiihimmlilmtqplmmpqpqppqmlilmmplmmpnmmlmmpmllmplppqCqqpppppqtCtClpmpqqqqtqpmlhihhmqqmlilimpmlihhihhehpDppmmpplllmpmmmmmpCDCtCLNC", -"nnpmillimqqCqppDBpoospypsCGCCCCCppppppqClCLLDtmpCqpqCqpqlmpmppllppCDpqCCqqqDDppqqiilmqqipqqqqqppmpqqqmmlliiilllmmmnqqqnmqqqqqtqqurqqquuqpptuuqttqtutqqqpmllimpmlqqutqpmqDDtCqCzCqCtzCtpptqppmpCDqtqtDDqDttqqpmllllmqpmllDDCqqtDDpppllDLlmlllmlhhiihhhlhhlplllCtl", -"qmqqiilmpqqCpmqCBolBBooBBBKCBoBKCUUzhghhpCCCCCppCpmqCqqClllllmppmmqCpqCqtpqCqppqqmqDtDtmqqtquuDulmpqqpqqppmllmmmpmmljliihihiiilmqqmmnqmimmlkilpqtqtqqpmptqqtqtqqqqqrtruDCqqqpppzpppplmplmpmlllpCilihlllpilmpqtqqqppCOODqztqpmqDLDCLDCLDptppqCqpmmmpqrCtqpqtqCNKt", -"qqDDpimpqqCDCtqqCooKColyCCBCBosCpKColppkCKplpCppUzpzzppqlpCtqtqpDtCDtCDtzqtzplmpqpqqlmqqtqmmmpmmmpnpqquuqqqttqqprqmmmmmmmmmlhilliiiiimheeiihhilihiiiilmmillmliliiihhimllmmllllllhihllllpllppmlpqlmlilmmtmllmqqmhllmpmhlmqqqmlilimilllmDUzqqDLDzqqDDLODCqmppCCtCL", -"LDLLDtqCLDUUCqLCLCqttqptDDCDDtCDqCLDCDOUDDDCDLLDuDEHuqqtDOEtqCuqtutqqqmltmlqtmllimmmimqmiilliiilnrnjiifbmnnjjjjijmmqqnieeeeeiiiijjmqqniiedeeehiihilhlilhhhiiliedheeehiiiiiimmmmimiiiheemllmqmeellhddhlliihimttqmpmppqqmllqpmplhpppllhhlmllmpqppqCpmlllqNqqqCLLDC", -"tqpqqppqpmqClmNVqpppmpmpDCtCttDNLDCqpqpmpqCDLDCmDqqqtuqpmpqmpmmilmpqtqtqpmlppmmqpquqqqpmlliihiiinnmjjjnmfiiffiffmjmmmmjijiijnqnqqqqnqrqqmmliiilmqpmihlmmmmpmpmlleeeiiiiiqmimmmidaeiqqmqqmmpqqmpqLqmlmppmtplhheddddddhlhhhmhhihhipqqqqpqCilpqpmlplllmmlillllllmpq", -"ppmplillllqDmlptmmlmmllmmlillllpCplilmlhllllpCqptplmpqqnhlmlmtpmppqtutqqtqpqpmpuquuqqqqqrqqmmlpmmmmiimmmifihijmmjmjjiijmiiiimmnnnnnqnqrrEurtuDEPqqplmmpqpmpqqqqmnqqqrDuujlimqqrrqqDEDmiihlmqppqqDqppquztqqmmmmpqmlllmpmlCDplpplhhhlllhhghlzDqllmpllllmpphlpqpmpq", -"qqqpppmpllzDplhdkhhllllltpllllmpqmllmpqmmlhlmzDCmqqpmpquqqppqDDuqtuutqqquqqpmmpqqqnpmqqquutqqqnpnqrrrrqnnqqnqqrnmmmmiimniieeeeiieiljlijmheeeeillqqqqmlieihiimmmmqmmmqrDErurnjmmqjmmmiedeeilliiilehhlmmmlmpqqppmplmppppppmqqqCODpqqqqqqpmlmtDCpmpplhhlomlDqplhhpL", -"ppqCCCDCCqpppmmqqqqqtpqqCqpqtqptDLCppqtpqCqCDCqlmqqqppqtDtqmpqpmpmmmmmqqqmlmmmllillmmmmmpmmmmliheiimnqnquuurqqnmmnrnmijmiifeeeeeeefieeiijliiheehehilmihhdeddhhhhihedehilqqmmleeeeeeihhiihhlihhhdddddddddddhhhededkmmlilmhlllipmhhhhhllmppmppqpmmCtzDOOCpqqqqqmmp", -"mpqpmpmmppiimppCzqqCzqpqplmpqtqpqCqmlllipmpllmlhmlhlmpmliiilllheiilihilmliilpqpmiilqqmliihillihdeadddeeiijmmmmmiimqnmifiiifeeeeeiieeeehieeeedede#.#dhilmheddeehhhiehehedaddiqqldiiiiiliidhhhihhhlihedhhlehihedhhdipmhhhllllhdhlhlhhhhlmpqpillhhhhhhlpzqpllpCDpll", -"ppplihlhdiklpidllhhhhedhlllqtqqpiilhhihhhihedhlmlihilmlhehlmpmllmmqpmlmmqpqqtuqqpmqruqpmmmmmqqmmqmmilhilhhiilmppmmnmmiiiiiiieeehjiieeijjhfhehiimllhihdddihhehhiieeheiheeeeimmmieadehiilmhehllhhlmmmlllqqDDqmihddhhhhdcddhdilhlCtilhhdhhlCplhhhhhhhdhlqDCmhdddhmC", -"mpmlhppqlDLOUCtUqmlllhhlhhhmqplhlllllmliimpmllllppqpmlmpttuDuqtqtuEIvuuwuuEuuutqvuquuuuvutuuxIxuuttuutqtqqpllmmmqrqqmnqqqqqqmmmmmmjmmnmlnmljimmmmilmmiilihehhlmpihhiimmphlmlhhipqqmiimmmlhlpqmmpilpmmliliihihhhhdhdhhilpqhlmhhlehilllhlmCqmlhehlhllllllehhlpqmlp", -"lllllllllpqqplmmzLLqqmpzqtCCCCDDDMOMEHDDtDLHDqDDEEDuuDEIOOEDDDtqqqtpmqurJIxvuuuutrtqquvIuuqqqqnpqtvIIIuuuuxutqtuxvxvxxvvrqqnqnlinqqqmmmnmqqmmqtmpmpmpmpmmmpmmlilpmimpqmimmqpmlmmnlilmppqqppqtqmpmpqqpmpqppmllmqqqmpqpllmhpqplpqqlllmlmmppmllllpmpppmpllhlllpqppm", -"CDDDCCzCCCDLCCCDCLLKLLDUCDDCqCDLDtCqCqqmqtzqqqpqtqqqqppqqtqqtqmmlmmmmllilmmpqrtqmmqqqqqqqqqqmlllpmlllpqtutmpqtqmurtrqqmmqmmmqqnmnnqrnqqrmnqnqqruqqqqqqqtqqqqmpmqmpmmqqtqqqqqqqpqqnqqqqqqtqqtttqtqqqqpqqqpmpmpqqDqppqqqppqCDCqCCDDDDNDCDNMNDNDDDDCDDDDLDLCDDDCDCD", -"zCCCDqCtztztqzCCqzmpzqmmmmpmmlptqmmpqqqqqqqqqqmmmppmpmmmpmmpmmpmqqtqqpmmiimnqqqmmmmqmmmlmpmmlmljllhimmpqpmllmpmlmmmmnqmmqmmlmmqmmnnnmnmnqmnqmlmqqppmpmpnpmmlmllmqqqqpqqttqmpqqqqpmnqqmmqmlmmmmpmpmmmmmpmqqmpmpqtqqppCDCqqtztzCDCtqtCzqpqtqCCCCzqCzCCDLLOCDLDzqCD", -"ppqpmlmmlllllppmzLzqzpikhlllllmpmmlmpqqqqqmmqqqmpmpqqqqpmppmpppmqqqmlmmpllmmpmilmpmmlmmmmmqmmilmllillmmlhilllllmmmmmqqqnqmmjlmjlmmiimjlimmmmmmmmliiiiillmmliehiltqqppmmmmllllmmpnmiihhmqqqttqmllllilpqpmpmlilmlmlpmlmztmlllmpqqpqpqztpmplpqqqqqpqqpmpppmlmppplpq", -"qqzqpllpllmlmpqmpKzzzpmpmpqqppqqpmlliliiqpmpqqpmqqqpmpqpmpmpmmmpqqnmmmqqiiiiiiiilmmmpqqtmqqqmiiiqmheehiiiimmmmmqqqpqmmlllmmmmmpmieeimmmmimmmnuqmillhiliiqqmliillqqmpmplhhhihhhlmqqiieimuDDDzpmlllilmqqpmllhhhhillmllllpllllmpqpqqpqCqpppmmppppqqCztqplihlllmppmm", -"qCCqpmmpmqqpqCzpmzzzzmlmpqCCqqppmmmlllilpmlmpqqpqqmmlilmmmmllllinqtqqqqqmmiiililmmpqqmpnmmqmmlmmqmmmliihmlilqqqmqqnqqqmmmmpqqqmmmjmmmnnmmqnmpDqillimllllqpmlliimmllmqqmihllmillpnmmiiimmmmihhlpqmmmpqqmliiliililllmlllllpmlppmpmmllmpmmmlllliillDCDCqpllmmppqqpp", -"pqCqplmppCCqpqCqLLLzLCmpmlmmpppmlmpnmmmqmmmmnqqqqpliliilllmllilmmqnqnqqmurqmpmnmpqqqpmmmmmmpmqqqmquuqqmmnmmmqqqmmmmpqqqqmpqqmmmimmmmmmmmqqqmmqmillmmmmmlilmllllllllmppplllpmmmpqmjiiihehhihhiqrCmlllilihlmqqmlllilllllllmlllmlllpllmppppmmpmlllmzqzqpmplmpqqpqpp", -"qCDCqpqCqDDpmpzqKCzpLLpmlillptzqmpqqmllmqmpqqquummmlllpmmpppmmpqqqqnmqquqqpnqqqqqmmmmmqtutqnqqpmqqqqmmqumnqqmmmmmlmmmmmlmmmmmlliifiiimjmqmmmqqqummmppmmmlmmmmpmpmmmmllllmmmmpppmunmiiihiiiliimlhllhhhhhimqHDqlhhlgdlmlhhlhhllhllheghililllmlllllplmllllmlpppmmpq", -"hlyyzKmhlyyzyKKKCLKKCCDLttqtDMONArADEDqDqDttDONCODuuDEuuuurruuqmrrrrqnnnnmnnnnmjiiliiimmmmqqqnnqqnmjmnnnmmmjmiifhiilmmiieiiliihhfeeflmmqquutpttpimqqqmmlqpmqqmmqlplllmllpolllopshlmlhlllmllllhlmpmlmptqlllihhhhlehhlpCqlhhhhilqzqttDtpmlhppmlilqpmllmllpppmpppll", -"zKSLKSKKzKKSLKSSNTONLLNLLDDNDHDuAqzDzqqqCqtqCNDtqnqqqqnpmmqqmmlijiijjjjiiifiimmmmiiiehiiiiimmiimjjiiiiiiiiiieeeieeimqqqqilllihedeeeimmpqxupqwIwsHDDDEIOIDuHEHuDIqqtpqCCpppsspoopLqppqqplpmmppmlpmpmlmpmlmpppppmllmpmlmllmmmllllmlmmmmpqqmmllpmlmpmpppmppqqqqpmpm", -"U0YYLDKCUSUTLLLLLLLLCCqplllmpmllmmmqqqqtmpmlppplllmmmlmmmmqpmliliifeiiiifeeeijmmmlieiiieliiiiheihiiihehinqqmiiimiimmnqqqqnqqpppmnmmnnmmmqtqqspttqpmpqtqpqtDtqqqpzCCCNLCpCLNLCCCCLCqDCpmqpptDCtqqqqtqpqpptqppqqppptCqqqDDCDDDDCqtCtqqtqDDCuqqDDqtDCDDNDCqCLOLDNU0", -"hllppypzKDKzCzypCpppplihmpqttqpmmimmmmlmmmlmomllmlmmlmllmpmmlilimiiijmjiiiiiimnqmmiimmmmmmliieeheiiiiiimmqnmmimmmmnqqqqqrtuuuuutuqnqmmiilmlkhlllmllmqpmhimmmmqpipmmppCplppppolpCmpCqmllqpqCLDDCCDCLqzCDCCqpqpppqqpmpCLLDpqpqpmpppmpppmmmlqqmpmqDCqpqzqmlqqpmlihl", -"hhhmpplhllllllmlppmlpllhmmliheddmmmmmhedhlllllhgllhkllllmllkilkhmiihiilimmmmmpmmmqqqmpqqmiiihehiimmmmmpqmmmqquqqqrqrqqqqtqqqqqpmnjljmllmmlhdlwsdhhlllihhdhhhptqlmlillmmlllllkloplmlhltphlmpppqqzqzppqCqqqpqqpmptmlillmllCCtqppqqhhhiiiliimpmpppDDCCzCCqplllkhhhh", -"pmopCqlhllllllkhlklllpmlttqpmlllqqqDtnlmllmppllhqplmpppltpmmppppmpmmpqqqttuutqqqqquqqnqqmmlmnpnqtrtqqqqquqquuvuqurrqnmnnmmlmmpmlmmimmmmqpqpltIHplmmlihllmllmquplqmmmmomplpppmllllpmhlmphillillmpmpllmpplllpqplllllplkhlmllhhhhllmlihhllplmilqqmmhihhhhllmllmpqpp", -"hhhlqqtqCtqpqppmlmpppppqIDDutqtuDDDMODDDIDHOOututqtCDDDCDDHCDDDDuDDuuuHIuvHIutttruqqqpnqqmmqtruuuuqqqqqqqpmmmlihqqnmmillllllmppmqnmnqnqqmqtuutqttuHuuuuIuuuwDuqqDtqtqpqulllmollhlqCpllmppqqpmlmlommmlmllpikmplhlpppmlhltomllllpqqmlihhililhipplhlmpmlpqpqpmhhhhh", -"ODqtttDNDDDHOOOHLNODDCDDUWPODuqtVUMODCtDtqqtqppqptNOOOONtDNNNCDHDIOEttDOuwDututuqqqmqnmlmmlmnqmmqmllmmpmlillllmmiilmimmqqqpmppmlqpnqqqqqplitulhlhimppmlmpmmtqppqCDDDtnqCDttqCHDCDqqqCDCqDMNCqtqpmptpllliNmhlppppplhhhhllqtppllmpqqqqppmmmtDtDqmpmqCtqqCDzCCtpqDU", -"OHCtCDtqtCDCqtqCtzCLDDDHEDDDqmmqDDDLOEqpmpqqqpmmllpDNCtNqtCttqsppqqpmpqIpquutllpqqqqmlmpmlmmmlililmmihiiilmpqqqpqqqmmqpqmpqtqtqpnmpqruqnqmmllmqtqplptqphlmqtqqppjmqAqilqLqmtqqCqqppqqqpmtpmpqCCtpqCDDDtqtCuqpqDOttuCtttIttttttttDCuDOVOOHMLMUMDMHLNMNNLOLLOMUULC", -"CDCtqttCDtCtqqtqCqmlmmqDDuDtqmpqOOOUUODqtqqqqqttppqHDqpCNCqplppqtDHDtqtDttuDtpppqquEutqmqqqqtqpqpqqqqqpqmpqmqqqnqqqqqnqquutpmmpltqqquuuuqpqqtttqwttuutqquHIIutqqqqDDAqmtDmpqlmppDqmlpqqpDzppqqqqCqqqpqzClpqtqppqppptttqqpqqpqppmqmmpnppmqqqCODqCppqCDDCLDLNDCDCq", -"qDILDqDEODqqppmptqqqplmpmlmmqmquOOVWXOODDIHDuuvIDtCDNtpmpmhhhhlppqDDtqtuHDIIuqqutttqtqqqtqqttqqtnpqqpnqqqrqqqqutrqqqqtqtuuuqpptqqqqqquuuqqpquvtqmppqqqtuuDHIIuutrqquunqquqqtmmmpODqpqCHNDDqqpptqDCpmppqClmptttqqpmpqCqppppqqqpppqqqqpqqpqtqDODpqDqzLLLDDCDLDCCDD", -"tDDDqpqDDtpllilhhhlmllhhlilmmmquLNOUONDDDDDIHDDuNDDLNDqlmplllllmntDEIuDIIIOIHuuIOvttuuwutqtuuutuuurqruurqtrtruuuqtruuuuvtuHuIIutqqmpqqqtuqmmqqqntqqqtqtIqtqplhhdmmmqqqqqEDDEDttqCttqtqCDLHDCqtCDLCztqzDDqpqqCDDHCtqtCttqtttttqpmppqqqqCDqzCDMCqDLCCDNLCzDLNCzDLL", -"qqpmllmpDqmiilhimlmpqqqEqmmmmlmntDNNDtttqqttrtqqtqtDEDqlpmpmmliilmqtqquuuuEIvuwIttquuHtpttuuDutuuuuuurqqqqqqqqnmnnpqqqtuDDEHOHtpuuqqqqquuqmlimmpupppppqqpmpmpmllnmnnrrruDqrODDqmqCNDttDHOODDCDDDDDDLNLNDLDttDDHHCDLLDzqqpmpmmllliilllmmpimqqqpqOLCzLOONNOODqqCqp", -"qqqpmqpqqtqqpqqqlmpmmlllmlllmmmmptCDtqqqqqpmpmtumqqqtDqililiillllmpnmmmmqqqtuqqummlmppmlqmptqppmnnnmmmmijmmjimiiliiimmpquutqquqpuqmmmmpmqqqmliljlhdhilllllmpqttqjimmnnmmqlmqqqplpqDtmlqDCCtqqpppppCDDCztDCDCCtqpmpDULpllhhhhllmmlmmmmllilmmlmlmDCqtDLLDCLCzpCCCq", -"CqqCAtAqCzDDDDDLttuDtmliliimmmqqppttttqpqqnpmqqummmmmqqmmmmmpnqqqqruutqqmmqqqqqqtppmpqtqpmllllllmqqqnmmmimmmimmjlllllmqqpqplppsqtmlhmmmiqqqmmimmlhhlppmpppllihegjmmnmmmmnmmqmmnmlllkhhllqqppppmlmmmpqppmqqtDtppmlmqCCmliehhilmptqqpqqqpmpqmllilqpmlpmllippqqqDCq", -"mmqqqmmmnqDDzqzqqpmlmlpqqqqqqqpqpppqqppplmpmpmmpnqpimqtmpmqqnmliimqqqqnqmmmqqmmmllmpqpmltqppmlmpmnqrqmmmmmmjmqrrqmmmmqtumqqqlpptItmmquqmqqmmimmmqqpqqpmlppmpptqqnrururrnuqqqpqtupptqqpppqppqtutpqqpqppqpptqqqqpppmlmppmltqpmlllmmlmpqqpmlliippmtmpqztpqCmqqpllll", -"hlmppmllhhlillqLmlmtqlimlqmmpmmqpCOUNCqtuHODttuItpqtCtttqtqtttppqqnrrruruqqruuqqqqqqqruuqqmmpnqqmqnmmmiimmiliiihhilllmmmqtqqmmlljimmiiilmqqmllilmllllllltqpmmmpmmliilliihihlqtqDDCDDCpmqtqqtqqtqDCppzCzzzLLCppzqzCDCpqCLtCDCtCDCturuDDuqtDqqDLCqCCCCCDCqCCqpppqq", -"illllllllhhlllhghilqqliilmpqqqmptCCpmlpqpqtqpmqqDtpqqqqqppqqttDDEDuuqqqqqqrtqqqqqquuDIDuDuuuuuuDutuuqqqpmmmmmmmmppqqquuIuuuqtqqmqqnmmjiinqqmpqmlpmppqqtqtututttqqmqqnpmphihmtqpqmllppmplpmlllpppqpmpqqpppmllmDCplllmtDDCzCzqmpmmmmljlllimqpmppqDKppzCpmpqpmmlill", -"pmppmllhhllmtqpmlmpqqpmmmpilpmiilpppolllllmmllllplllmlppqppmlmppqqnmmmmmmqqqmlilmqqqqqpmqqqqqqqpmqmpmmmippqqtutqqqnpmmmpuqqqqqqmnnmmmmmmmmimmqplmppmppmpmqtuuqppmqqqqqmmqttDOHqttqpmpqplllpppllllmpmpmlllpmlllmpqpllllhhqCCqppppliiiilmmhmlmpmpDpplppllmllllllmm", -"llppqpmlpqqpmllmllmlimpmCqmlmllpppCCtppmppqqqqpmpmlpppqtttqplpmmmmmmmqqqquuuqpmqpqqplmmqmmpqpmlmmlmmmmllnmqqqqqqqqqmllllmlilmmmlmljmmmqqqqpquuqplmpmlllllpqtqpmhmmqqmmlmpqmptqmpqqpllmldlllihdhhlmmpmlllmpplihlmhhhhdhlphhhdehilmmihilmphlhlqqlikhllllpmmllllmmp", -"illmqttqCDLCqppqpqqppqqtOOCqtqtOTNDCDCDDHDDDHuutDtDHDDCDDLHDDONHDIHDtDDIDIOOIuutimpmlmqtmpqqqpmmhiillljmmmmmmmlimmllilmqmlllmpmmqnpmqqqpqmqtutpmtuuHuuuImpqtqpllmqqqmmmmlmllqmlqlplllppmDtplhlpqqtqppppqtmhltDqlghhhllquppmllpttqpliiihillhmCphghophlpqltpmlllmm", -"ODtqqDLNtztDUUOLDLOMOMOMOOMOLqmDNNLLNCqpqtqqqqqpqtDOODDDqDDCDDHDDLHqquNDuuDuDtttpquqqqppqpqqqqpqmpmqnqpqqpqpqmmmilililmmqpmqqqqqqqnqqqqnllppmlllillmlllhlpqqqpppqnqqpmpqmqpqDtqtpppmpqttDDDDDDDDtttqqttDDtmtOOCqutqtIHtltttmlpppuqqqpqqqqDDCDpmCpCLtzNLtDDtqtuDI", -"0ULCDLDLCqppqtqpDCqCqpzNLLCCDplpCCNNOLplpmppmommllqDDDCCtDCqptqlmtqpmqDtppttpplpuDIHDuqpuututuDDuuuuuuuuqqqqqtqqqqqqqpqqqqqqqqqpmmpqtuttqmpqtqqttqqtqppmmpqtqqpqqqqqqqqmpqmpqmpqqplllmpmpppqCtppCqpptqtttDHONttttptDWVHqHOHutttttttuDILOLNLOUCCOCLNTOLOLLDMOOUXU", -"qppqCDCqmmpmmqLVUCpppmtVLtqzNDzOUOLNUODtuCutttuupqDNNCtDDOODDLDCtDNtptDDtDHupmptlllilpqmpmmmmpqtmmmmllilmmmmpmqmpqqqpmpmtutqpmmmrtquuvuqqpmpqttxtqtuuuqtuHIIHuuuqquuEuqpuqplmmpDOqlptttqHqlllqttppllptqppmpDDtplklptqpppllppppmlmqmpqppmppmCUCmpplpONppNDDDDDuqq", -"qCDqqCDDNDDNODCCqtDDCDLOCDLOLDDCNTXUOCCCttDDDDHDHDDDOOOLDHNOOOONDOODtqtCuHOHtpppmpmlmpppppppqqqqpqqqmmqqqqqmmmmlqqtqquutJurtrutqqqqqqtuutqptutqlmpqqtquuuDIDuqtquuurpqqqqutqqtqqDCqqtDDDLHCtqtCDDDtqtDHtDppqtqqDutttttpqHOItqtpptqqqtqqCqCDKDzpCCCCLUDCqLUOtqttq", -"tDLCqzCCODLLLCDDCDLDDDNO0OztOUUOLTUWUNDOCuDDuIEHDDNOUVOOOOOONNDDOOONDCDODHIDtlllqqtqtDDDtDDDDtqtuuuuuuuuqqtqtuuqqququuvuEuuuuuuqtqqqqqttppmpptttHutqqtuDDIOOOOIOJIIEuuuuDDDDtqqptttqqtCNtqtqtqqqtttqtCCqtttqtDHCtttDHutDtHtttuHuODuDDDDLpCCCKtpKCCzCCCDLDNDqqtDq", -"DLDDztCDLCqqqqqqCCtzCCCCNCpCNULpsCDCtCtCqppqpptqpqtDHDDCDCCDDNDDDDDqqqtDuDHuqpppptqpqtqpmqDDtqqtuqqqqqqppqqpmmpmmmmmmqqqlmmpqqqquqqpqtqqqplhhllmpmllmpqputuDDIIDEuuurqmqquDDIDtqDLOHCtHVONDNDDHDCNONODOOCONtCOHqDDHODDtDDDtqtCDDIDCttqtCCLNNUTLWLLNUUNLOONDDDDDE", -"qCDCtzCDDqppppppppppqCqqpqCCqpppptCCCpqqqpqmpqquqpptCDtppmmptDDCppppllmmpqqtttqtttqptqpllppppmommmpmpmiilmlihihhilllllmmililmmpmqmlilmpltqpkhhllhehilmliqqpqtqqptmqqpiipilmpqmllppqqllptDCqqppqtpqDDtCttDNDDtCqpqtDHCtptttttqttCtqpmppmpltzKNCCLpBDNLqppCqpqpppq", -"ppqtqpqqCCqpqqqppppqCtpspCCqllsDoppqppplppmpmptDCqpmtCqpqpppqqppqrrrqqqpilmqqquuDDHDIOODIDtqpplkmpqqmlllillllmmmmmmmmmmptpmmlmlluqllmqpmpmpllllplmppmlllqqqqqqpmrtuvqilqqmpqqmlihlllhllptqpppllpmmppzCqmCqCDzpmmkmtzqqqqpqpqqCztqpppqqpolppCNCopCzppmlpqqpmppmpq", -"mpqqpmmpqqppqCqmllpppqpqqqstCtCCmpppqppppppppquIOtqqCDtpttqqttqpqtuDuqqqpqqnqqqqtDDHDNHHNDppppmlmqqqpllmilmlmppmpllmlllmmmmllmmmtqpmpqppmpppllklppmliilmqpqqqqpmqqrtmllqqppqtqppmpmpqqtDCqtDDtpqtqqqLOLqCqqLDppCmpCtztztqpqpqppqtqppqCtppCLNTCopCCCCCpqCpppqqtqq", -"ppqDCppqCqqpqDCppsqsppsCCszCLLqoNNDDCCDDuDDuuuOUUOOHOOLDqqttCCtqqnqqrrqqrqtrtqqqpptppppqqpmppppppqqqpmmlmmmilmllmllmmlilllllmmpqmmiihhhhpppllkkhllihhlmpmpqqqqmmmmpmmiiliehmqplmlllompqqqppCtqptpplmqLCpqqzCCCzDqDDCCCCqCqmppmpqDtqpqCCqptpCKsloppqCCppmmmpmqtqm", -"pqCOLDDONLDtLOOCLNNLCCNUNNCCspsqLCppomppppqpmptupptqqppqppqCtqqtnqqruuuuqqqqqrqqipppmpuDpqptqqqpuqttutqqpqppmpmmpmmqqqpqqqqqqqqqutqpmmllqqppomppqpmpqtqqqtDDuqppqqqqqqqlmlltDqpplmppllmptmlmpmtMpmllpCCqlpCmmqqplpmpqDCqqmlmmpCOOHqppCLCpszCNLCNUCCzCzqqCLIDDOEq", -"qDDDDtCqzCCKDCzyHLCCCDCqDCDLtmllpllmqttqqppqtqppqDDppqDtqqpqppptplpzppzqlmpmmlpqDDDDNOODpmlllhklimmmmmmmimlilmpqmqqpuqlmIumliililllmpqqquuqqnqmmmqqpmlihlmqutmlmmmqqmpqqqquuuquuuuqquuuuIIvuuvuxqutuDOMDDEDHOUODDHHDDNODCCtttDNLuDEIEEIODDDDMLMMCqqpqtttptCqpqCC", -"pqtqqqqtqqqzCzppztqqCCqlpmpqCCDNpplomqqptpptDCuCpqtmmppmttqqmlilllpzpCLDDDDtttquONDCDNDtCtttDtDHEIEuqppqqqqmmmqpqqqqqqqqtqpmppqqpmmllpqqmqmmmmnmimpmlllimmqtqmmppqqqmiilqpqquqqqqqqqmpqqvutqqmmlmmmmqqtqqqqqpqqmllmllpppHODDDNIDqqqmpmmmqqqqquDDmllppqqtqplpqDtm", -"mqqppqCzCpppzCBpmpqqqqmlCqppzLOLOLDDDDNLDDCDLCqqLOUONLDCCDLNCpqtppCDzCDCUNDuCutqODqppqqpONDDtqpqtqqqmmmmmqplllmmllllhillmlmlmmmmpplllilmmmmlmnmmlmmmmmmllmpmpmmqmmpnpqqrqqqquqqqqqmpmmmmtqqqqqqmppmllmmlqtqpmmmpqqtttqtqDIDtuDutuqppnppmmmilmmqpttqpqpqptqppCDtl", -"uDqqpqqqDzptCLCpCDLNLDCqDNDqtDDtDDLCCzCDLDCDDzpppqtpppmlmpqqDtzCCCLNCqzpDCqqqqquCqplmpppqqppqpqqqqqqqqtqppqpmppppmqtmptqpppppppmqppllllmppmpnqqmmpqpqpqpqttDutuDquutqqqquqquuqqqqqqnqqpqqqqtuuuuIODuuDDupqqqqttquttqqqtttttqqqpluuqqtuuqDuDDDILDDDDDDttqCDODDDDu", -"UOODDDDHCtpzCLCpqDDCqCqtpDLCqCCqpqtqppqCqppqCtpmCCCqqqqqtpmpzqtqppCLtztpqttqpqDDtqpppqqtCqttDtqtDuDDDutqquuqtqtquqHIqtIuuuuqqqqpqqqtqpqqqnqqqqqqqqtqqtqqqqutqqtqqqqmmmmmqpmmpmmlmpnpqmqqqmqmqqqqlmmmmmqpmlmpqqqmqmmmmpqqqqqqqqpmmpqtqppqmpmqqppmpptqtCCuqHODttLU", -"qqplhlllqpppCCpplpqmllmplpCCqqppqqqqpqtDtpmqqqppmpmlllmpCqptCCCCppCDypqmpqqqpmqDqqqqtpqqDttCtpllmpqtuqqpuDutqqqpmpqqpqqtqpmmppmmmptqqqpqmmmqrrqrmqpmpnpmmppmpqmmlillmppqpmllllilmmpmqqqmqpmmpqpnqqtqmpmmliimqpmimllmmmqqqqqppqmmllqqpmlmqqtqutqqlmpppqqtpqCtqCHO", -"DDtqppqtmppqCCppqCDtppqCqqqqqpmpppppppqCLzptzqqppmppmpqCmmqzzqzDCCNNCpplmpppmppqttptqpptplmqDtpppqqDLHDDqttqqppmpqpqqttumlklmplklmppmlmmlllqqqqqllmllmmlqqqqqttqqqmmmmmmqmmmmmpqpmqqqpqqmqqqruuuqurqmlihmmmqqpmmlimpqpmqmqqqmmqqptttqpppplmmppppttqqpmppptqpqqtq", -"qtqmlmllpqCCDCzppzDCmpqqDpmpqqqCzqpqqzCDDtqzDCDLqqCqCCDLCNUVNDDOLCUULCtpqpqqttuuCqqttqDDLDHOOLtmDqCDDMDDtDEDuuuttuqpwDuOutqtuHuqilmmlllmmimmqnmnmpmmpqqpmmpmmqqqmpmmpqqtnpqqqqquqqtqqqqqppqqutqqqquqqmmmmlmqqmmqqqtuuqpmqquqnpqqttqqtttqppppqqtuDDDqpppqqDNDplpp", -"qtttuDuDuDDNUONCCqppqDOUUDCDNDDDCDDCqqCLzCCCLONCCCpqCDLNLOOCCDLLNCCNDCtpttqtDIIItDCqtDtqtCDNDtqtLMLDCDDODDHLDutuDDuuDDOOVqtDDDOqqtqtqqqqtqqqtqtuuqttuuuDpqqtDutqpquwuuuuHuuuutuDDuuuIHuDqquHIDuqnquqqqquqquruvvuuuuvuqruuuvxuuvuIwuHIIwDIDuDOPODDUOHOMHODOUICtCD", -"IIDDDDCtDNNNOUUNOLDCDLOUDCDLLDCqmqLLOLNLHDzpmqzqqqqCLOOOCzLOLCCDCCLUHDNDOODDuttqDDDCDNONqDDDtzCDLDtqqqDDDHDDuCuDtqqqqtDDDtqqmtDtpqtDtutuqqquuruuquqtuDtuqtuDuDuquIODuDIIIDuDuuDIIDDIOIIIIIIIOODuvxuEuvEIurqqqqqquruuutquvutqtuvJuuwIIIHwutqtIOIDtOODNNDCNOONDttD", -"IDDuDwDCDDOOUUOULCqqzCDDXLtqCCDOUULCzqqqCLLDztzCqpqzDLLCzpzONqmzppCHpppplllmpqqtllpmpqqqmptqmpptppqCCtmlDCqpppttttttqtDHtDHtltODmmmppqqqqqquuuuutqtrCuAtqqqqqtqtDHDutDHOOIHDutIUOIHOPOOOutqqqqtttqqtrtqmqqqqqqqntqquurtqqquuuuuutsqCIHDDHuttNOOHLOONVODNONOODDCD", -"qpppqqqtptHUONGNqpllqDDCUCmlmpCLLCmlllmpmCLLtzCLMLLLNLDzODCLLqqCCtNUCqtqDtutqqqpmppqtttpltDDtpmppqLOLzppqqppmpqqqtqppppqpqtpmpttqmpmmmtuqpqtqqqqppmmpqqqqqqqqtDDqqqppquDtuDuqqtOutuDDuDDtqppppqqqqqqqmmmmmmmmnpqmmmqqpmmlmqquupmplpttttqtqppqqppqtpptCtDDqqDCplm", -"ppmpppolppCHNCCDCqpqCONMNDDLNDDCCDLLNLCqNMLCpzOYYUOLUUNLUUMLCLCzCtDUHHNDOOIDttqqttqDDDDDDOUODtqtMUNLCqDUpttqpqttqCDqptDDtppqtpmCDDDqqtuDmmmqqmmmlihillmmlllmlmqqmppmpquDqqqtpmpqqqpqtqqtqtqpmpmpmmqnmmjmmlilmmiilhllllllmlllmpppppmpttqtDCppqCqqttqqDCqDDCDODqmp", -"qtttuuttDttDDDNWDCqqDOUULDCDNDDCLMNMLLDLLLDzqpqLpmlmmqzCpzCqzzqllklpmlmlhhklmptuqmlllppDttqplllmCCzCpmqOpqCqtttqpqtpqDHDttqtLtqDqzCDCqmpmmpmpmmmmllllmpplmmmllmptqtqquDCDDHEDtqDDDDDDDHOuttqqmmleimmiilmnnqnqqqqppqqqpqttqpqtuDuutuHOOHDONDDNONLDOOOUHCDOOUUOHCt", -"pqquuHDuutqHNDCNCqmppzDLtmillllmhhhilmzLllmppihelhehhillmmllmlihlkopkhklllllllmpqlkhhlmplhhgdhhkmllmpllpipqpmqpphhhhhomilqlhmplllmmpmmllqmpqqpqqtqqqqqqquuHDuuDEuDDtuDIDOOOODuDDIHDIHDMODLIDttqtnqqqqqqqutruuvvvqtttqptDtttDDHDtCtDOUOLDCqqqqqqppCCttqpDpCtqppqp", -"mpmppmlklllCDpolmllhlmqCpmpqqpmlhlqzpmllzppzLCzqLDzpqqpmDlillhhlhkmpkhmppomlhhlmlkhilhghllhlllmmpihllllphmpllppmhlhdhmlghtpdhpmhmlmllmpqqqqquruuDuuuuqpmmqtqqqtDqtqqtDOOuqqppmmppmmpmmptmpqppmmpurqqqqqnurrqrqqqllmplhlpDqlhklmlllpCDCplqqpppmllpqpmmlqVlqtliptq", -}; diff --git a/sandbox/texture-paper.xpm b/sandbox/texture-paper.xpm deleted file mode 100644 index 35f805b..0000000 --- a/sandbox/texture-paper.xpm +++ /dev/null @@ -1,87 +0,0 @@ -/* XPM */ -static char *on[] = { -/* width height num_colors chars_per_pixel */ -" 32 32 48 1", -/* colors */ -". c #f8e0d8", -"# c #f8e0d0", -"a c #f8e0c0", -"b c #f8e0b8", -"c c #f8d4d0", -"d c #f8d4c0", -"e c #f8d4b8", -"f c #f8e0e0", -"g c #f8e0d8", -"h c #f8e0d0", -"i c #f8e0c0", -"j c #f8e0b8", -"k c #f8d4d0", -"l c #f8d4c0", -"m c #f8d4b8", -"n c #f8d4b0", -"o c #f8ccc0", -"p c #f8ccb8", -"q c #f8ccb0", -"r c #f8c4b8", -"s c #f8c4b0", -"t c #f0e0d0", -"u c #f0e0c0", -"v c #f0e0b8", -"w c #f0d4d0", -"x c #f0d4c0", -"y c #f0d4b8", -"z c #f0d4b0", -"A c #f0d4a8", -"B c #f0ccc0", -"C c #f0ccb8", -"D c #f0ccb0", -"E c #f0cca8", -"F c #f0cca0", -"G c #f0c4b8", -"H c #f0c4b0", -"I c #f0c4a8", -"J c #f0c4a0", -"K c #e8e0b8", -"L c #e8d4b8", -"M c #e8ccc0", -"N c #e8ccb8", -"O c #e8ccb0", -"P c #e8cca8", -"Q c #e8c4b8", -"R c #e8c4b0", -"S c #e8c4a8", -"T c #e8c4a0", -/* pixels */ -"h#kyGCmmmmvmvyjjyyCpjvjvuhhivjia", -"LmymvvyllyyithLvLyvjvpihjjyli#kg", -"CDCQyyCCGyikyCCCyLyNMxyyyLmulyRS", -"NqmvjyCyvuimLLymmCpmmjmCvyyCOAGm", -"jvliivvyymiyjCCpvmjmjvjjmyyCCvij", -"uvyvCiiujixCGmyjymvmvljyCCCvvuuj", -"yyyllBxmONyjyxukxBlxlBCrCjiljkwK", -"pyCCyQSIDDmymCyyCGCRFIzCLmmyyOTT", -"yyjvmvyjuuvxlijvjmmjjjjeijjyjDmj", -"vyvjuiyjjhllliiixljjullylmLjaivv", -"vihhivuuhiuhwxCGCvhkvvyyCyujvjuj", -"CopCCxCCpmxCQCCmxBmLCCCyyyCpCCxy", -"ypmmyyyyyvyyLCyCCRDmyyvymCyvyjpv", -"vjvjvjlujiiiyyCyDjjKjjmymmvjvyvb", -"jyliiiyyxiijymyCpmymNCBjuKimmliv", -"mwhipyliavjjvyCCvmyyuuxmyijyjvmy", -"yjlDNGvmKmmyNLyyCCCCHRSyylyyCCQG", -"jmCsOyyGymyCyjyQyryDnmCjvmyjmmyy", -"NHHyyCyjyjmyCymyyiiuvvuyxlikyyjy", -"mmCymmyymyrCyvyyyimuyyxhhuCmjyQE", -"GCmCyyjmpmmmmvxxliyylkllCmyDSCmy", -"yyCNNNSPCyCCmyByCyyCMPDDOTTRJRTL", -"yppmyCCmyyylijypjvmymCmmDyvmnmmj", -"vymCymvvjlvjyymmvmmCmmvvjyppmiyy", -"CCvmjpjyxlymyyCyyNmjmyvyCyivyyyv", -"CpyyNNyyyyOOCmyvyvCpmCyyyOyLCCCC", -"pypNmxilypDzppymyxdmCyvymDpyLyyy", -"yydhlxyjmyyluvlltiumjyyymjvvjlku", -"cgljjyvpiilyihxyyjvyyyliiiikjyml", -"xymNpihiLChlyyymmyCylixvxiyCjl.t", -"NPREmxyCGCyGryCCCCyCCCLmCypLyLmm", -"mygfxyzHbypvjvvyjKjrHRbjvLjbtvbe", -}; diff --git a/sandbox/trash.xbm b/sandbox/trash.xbm deleted file mode 100644 index 0370f11..0000000 --- a/sandbox/trash.xbm +++ /dev/null @@ -1,6 +0,0 @@ -#define trash_width 16 -#define trash_height 16 -static char trash_bits[] = { - 0x00, 0x01, 0xe0, 0x0f, 0x10, 0x10, 0xf8, 0x3f, 0x10, 0x10, 0x50, 0x15, - 0x50, 0x15, 0x50, 0x15, 0x50, 0x15, 0x50, 0x15, 0x50, 0x15, 0x50, 0x15, - 0x50, 0x15, 0x10, 0x10, 0xe0, 0x0f, 0x00, 0x00}; diff --git a/sandbox/triangles.pl b/sandbox/triangles.pl deleted file mode 100644 index 23dc1f0..0000000 --- a/sandbox/triangles.pl +++ /dev/null @@ -1,69 +0,0 @@ -#!/usr/bin/perl -w - -use Tk; -use Tk::Zinc; -use Controls; -use Tk::Photo; -require Tk::PNG; - -$mw = MainWindow->new(); -$logo = $mw->Photo(-file => "logo.gif"); -$papier = $mw->Photo(-file => "texture-paper.xpm"); -$penguin = $mw->Photo(-format => 'png', - -file => "xpenguin.png"); - -$top = 1; -$zinc = $mw->Zinc(-render => 1, - -borderwidth => 0, - -highlightthickness => 0, - -relief => 'sunken', - -takefocus => 1, - -tile => $papier); -$zinc->pack(-expand => 1, -fill => 'both'); -$zinc->configure(-width => 500, -height => 500); -$gr1 = $zinc->add('group', $top); -$clip = $zinc->add('arc', $gr1, [50, 50, 399, 399], - -filled => 1, - -fillcolor => 'Pink:40', -# -fillpattern => 'AlphaStipple4', - -linewidth => 0); -#$zinc->itemconfigure($gr1, -clip => $clip); -$gr2 = $zinc->add('group', $gr1); -$clip2 = $zinc->add('rectangle', $gr2, [200, 200, 450, 300], - -filled => 1, -# -fillcolor => 'white:100|white:0', - -fillcolor => 'white:100 0|black:100 100/90', -# -fillcolor => 'white 0 |blue 20|blue 80|black:0 100/270', - -linewidth => 0); -#$zinc->itemconfigure($gr2, -clip => $clip2); -$view = $zinc->add('group', $gr2, -tags => "controls"); -$zinc->lower($clip); -$zinc->lower($clip2); - -new Controls($zinc); - -$cv2 = $zinc->add('curve', $view, [], - -linewidth => 2); -$cv3 = $zinc->add('curve', $view, [], - -linewidth => 2); - -$tri2 = $zinc->add('triangles', $view, [50, 50, 300, 50, 150, 150, 300, 150], - -colors => ['tan:50', '', '', 'red']); -$zinc->contour($cv2, 'union', $tri2); - -$tri3 = $zinc->add('triangles', $view, [150, 150, 50, 50, 150, 50, 300, 50], - -colors => ['grey50', 'blue', 'red', 'yellow'], - -fan => 1); -$tri4 = $zinc->clone($tri3, -colors => ['grey', 'red']); -$zinc->translate($tri4, 100, 300); - -$zinc->contour($cv3, 'union', $tri3); -$zinc->translate($tri3, 0, 300); -$zinc->translate($cv3, 0, 300); - -$zinc->monitor(1); -$mw->Tk::bind('