Portage depuis perl

1 files changed, 116 insertions, 0 deletions

diff --git a/demos/allOptions.tcl b/demos/allOptions.tcl
new file mode 100644
index 0000000..bc3e4d2
--- /dev/null
+++ b/demos/allOptions.tcl
@@ -0,0 +1,116 @@
+# these simple samples have been developped by C. Mertz mertz@cena.fr in perl
+# tcl version by Jean-Paul Imbert imbert@cena.fr
+
+if {![info exists zincDemo]} {
+    error "This script should be run from the zinc-widget demo."
+}
+
+set w .all_options
+catch {destroy $w}
+toplevel $w
+wm title $w "Zinc All Option Demonstration"
+wm iconname $w "All options"
+
+frame $w.buttons
+pack $w.buttons -side bottom -fill x -pady 2m
+button $w.buttons.dismiss -text Dismiss -command "destroy $w"
+button $w.buttons.code -text "See Code" -command "showCode $w"
+pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
+
+# The explanation displayed when running this demo
+label $w.label -text "Click on one of the following\nbuttons to get a list of Item\nattributes (or zinc options)\nwith their types.\n"  -justify "left"
+
+pack $w.label -padx 10 -pady 10
+
+
+# Creating the zinc widget
+zinc $w.zinc -width 1 -height 1 -font "10x20" -borderwidth 0 -relief "sunken"
+pack $w.zinc
+
+# 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 type {tabular track waypoint} {
+    set itemtypes($type)  [$w.zinc add $type 1 0]
+}
+
+# These items needs no specific initial values
+foreach type {group icon map reticle text window} {
+    set itemtypes($type) [$w.zinc add $type 1]
+}
+
+# These items needs some coordinates at creation time
+# However curves usually needs more than 2 points.
+foreach type {arc curve rectangle} {
+    set itemtypes($type) [$w.zinc add $type 1 "0 0 1 1"]
+}
+
+# Triangles item needs at least 3 points for the coordinates 
+foreach type {triangles} {
+    set itemtypes($type) [$w.zinc add $type 1 "0 0 1 1 2 2"]
+}
+
+
+proc showAllOptions { w type} {
+    global itemtypes
+    if [winfo exists .tl] {destroy .tl}
+    toplevel .tl
+    set title  "All options of an item $type"
+    #my @option return
+    if {[string compare $type "zinc"]==0} {
+	set options  [$w.zinc configure]
+	set typeopt "optionClass"
+	set readopt "defaultValue"
+	set  title  "All options of zinc widget"
+    } else {
+	set options  [$w.zinc itemconfigure $itemtypes($type)];
+	set title  "All attributes of an item $type"
+	set typeopt "Type"
+	set readopt "ReadOnly"
+    }
+
+    #.tl configure -title $title
+
+    frame .tl.f1
+    set bgcolor "ivory"
+
+    label .tl.f1.opt -text "Option" -background $bgcolor -relief "ridge" -width 20
+    label .tl.f1.typ -text $typeopt -background $bgcolor -relief "ridge" -width 20
+    label .tl.f1.rd -text $readopt  -background $bgcolor -relief "ridge" -width 21
+
+    pack .tl.f1.opt .tl.f1.typ  .tl.f1.rd -side left
+    set nbelem [llength $options]
+    frame .tl.f2
+    listbox .tl.f2.l1 -width 20 -height $nbelem
+    listbox .tl.f2.l2 -width 20 -height $nbelem
+    listbox .tl.f2.l3 -width 20 -height $nbelem
+    pack .tl.f2.l1 .tl.f2.l2 .tl.f2.l3 -side left
+    pack .tl.f1 .tl.f2 -side top -anchor "nw"
+
+    # Remplissage des list box
+    foreach elem $options {
+	.tl.f2.l1 insert end [lindex $elem 0]
+	.tl.f2.l2 insert end [lindex $elem 1]
+	.tl.f2.l3 insert end [lindex $elem 3]
+    }
+}
+
+pack [frame $w.col]
+
+set width 0;
+foreach type [lsort [array names itemtypes]] {
+    if {[string length $type] > $width} {
+	set width  [string length $type]
+    }
+}
+
+foreach type [lsort [array names itemtypes]] {
+    button $w.col.$type -text "$type" -width $width -command {showAllOptions $w $type}
+    pack $w.col.$type -pady 4
+
+}
+
+button $w.col.b -text "zinc widget options" -command {showAllOptions $w "zinc"}
+pack $w.col.b -pady 4
+