Perl Tk scroll de plusieurs colonnes de Frames

[dmganges]

Bonjour,
Rien d'opérationnel ici, juste un cas d'école, même si je n'ai plus l'âge !

Je cherche à scroller plusieurs colonnes contenant plusieurs lignes contenant elles mêmes plusieurs Frames.

Ça pourrait servir par exemple à générer une bataille navale sur un océan de cases (Frames)

1er essai :
La barre de scroll dépend du cadre général contenant les deux colonnes.
Le scroll fonctionne, mais l'affichage se dégrade :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
#! /usr/bin/perl
use strict;
use warnings;
use utf8;
use Tk;
use Tk::LabFrame;
use Tk::Pane;
 
my $NB_LIG = 30;
my $NB_COL = 30;
 
my(@lig_casesG, @CaseG, @lig_lig, @Lig, @lig_casesD, @CaseD);
my @tab = (0..$NB_COL,0..$NB_LIG);
 
# Creation du widget principal
my $Wm = MainWindow->new(
  -title      => "Essais scroll 2 colonnes de frames découpées en cases",
  -background => 'white',
);
$Wm->minsize( 800, 400 );
 
# Cadres
my $couleur_commune = '#E0F0FF';
 
my $cadreHAUT = $Wm->LabFrame(
	-background => '#FFF111',
  -width => 20,
  -height => 20,
  -label => 'Cadre HAUT',
)->pack( qw/ -side top -fill both -expand 1 / );
 
# NB Le Scroll est dépendant de $cadre
my $cadre = $Wm->Scrolled('Frame',
	-scrollbars => 'e',
  -width => 20,
  -height => 20,
  -label => 'Pour voir',
)->pack( qw/ -side bottom -fill both -expand 0 / );
 
# j'ai essayé çà mais çà ne fait rien :
$cadre->Subwidget("yscrollbar")->configure(
	-repeatinterval => 1500,
	-repeatdelay => 1500,
);
 
my $casesG = $cadre->LabFrame(
	-background => $couleur_commune,
	-relief      => 'groove',
	-width => 60 ,
	-label      => 'Cases gauches',
);
 
my $lignes = $cadre->LabFrame(
	-background => $couleur_commune,
	-relief      => 'groove',
	-width => 10 ,
	-label      => 'Lignes',
);
 
my $casesD = $cadre->LabFrame(
	-background => $couleur_commune,
	-relief      => 'groove',
	-width => 60 ,
	-label      => 'Cases droites',
);
 
# $cadre contient :
# Deux cadres G & D qui vont contenir plusieurs lignes de cases
# séparés par une colone qui contient le n° de ligne
$cadre->pack(qw / -side bottom -fill both -expand 1 /);
$casesG->pack(qw / -side left -fill both -expand 1 /);
$lignes->pack(qw / -side left -fill both -expand 1 /);
$casesD->pack(qw / -side left -fill both -expand 1 /);
 
# Lignes dans cadres
for ( my $numlig = 1 ; $numlig < $NB_LIG; $numlig++ ){
	#CasesG
	$lig_casesG[$numlig] = $casesG->Label (
  	-width => 2 ,
  	-background  => '#AAE0D0',
  	-height => 1, )->pack(qw / -side bottom								
  														-fill x
  														-expand 0 /);
 
 
  	for ( my $numcol = 1 ; $numcol < $NB_COL; $numcol++ ){
  		$CaseG[$numlig][$numcol] = $lig_casesG[$numlig]->Label (
  			-textvariable => \$tab[$numcol],
  			-width => 2 ,
  			-background  => '#AAE0D0',
  			-height => 1, )->pack(qw / -side left
  														-fill x
  														-expand 0 /);
 
  	}
 
  #lignes
	$lig_lig[$numlig] = $lignes->Label (
  	-width => 2 ,
  	-background  => '#AAE0D0',
  	-height => 1, )->pack(qw / -side bottom								
  														-fill x
  														-expand 0 /);
 
 
  	for ( my $numcol = 1 ; $numcol < 2; $numcol++ ){
  		$Lig[$numlig][$numcol] = $lig_lig[$numlig]->Label (
  			-textvariable => \$tab[$numlig],
  			-width => 2 ,
  			-background  => '#AAE0D0',
  			-height => 1, )->pack(qw / -side left
  														-fill x
  														-expand 0 /);
 
  	}
 
  #CasesD
	$lig_casesD[$numlig] = $casesD->Label (
  	-width => 2 ,
  	-background  => '#AAE0D0',
  	-height => 1, )->pack(qw / -side bottom								
  														-fill x
  														-expand 0 /);
 
 
  	for ( my $numcol = 1 ; $numcol < $NB_COL; $numcol++ ){
  		$CaseD[$numlig][$numcol] = $lig_casesD[$numlig]->Label (
  			-textvariable => \$tab[$numcol],
  			-width => 2 ,
  			-background  => '#AAE0D0',
  			-height => 1, )->pack(qw / -side left
  														-fill x
  														-expand 0 /);
 
  	}
 
}
 
$CaseG[1][1]->configure(
		-background => '#FFE0D0',
);
 
$CaseD[5][5]->configure(
		-background => '#FFE0D0',
);
 
MainLoop();

# j'ai essayé çà pour ralentir, mais ça ne fait rien :

Code :

1
2
3
4
$cadre->Subwidget("yscrollbar")->configure(
	-repeatinterval => 1500,
	-repeatdelay => 1500,
);

Deuxième essai :
La barre de scroll est indépendante.
Le scroll fonctionne pas.
Je constate que c'est la fenêtre de lancement (DOS) qui scrolle !!!

Code :

1
2
3
Petit à petit j'ai ajouté des :
$defil_v->configure( -command => sub {
jusqu'au niveau le plus élémentaire, sans succès :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
#! /usr/bin/perl
use strict;
use warnings;
use utf8;
use Tk;
use Tk::LabFrame;
 
my $NB_LIG = 30;
my $NB_COL = 30;
 
my(@lig_casesG, @CaseG, @lig_lig, @Lig, @lig_casesD, @CaseD);
my @tab = (0..$NB_COL,0..$NB_LIG);
 
# Creation du widget principal
my $Wm = MainWindow->new(
  -title      => "Essais scroll 2 colonnes de frames découpées en cases",
  -background => 'white',
);
$Wm->minsize( 800, 400 );
 
# Cadres
my $couleur_commune = '#E0F0FF';
 
my $cadreHAUT = $Wm->LabFrame(
	-background => '#FFF111',
  -width => 20,
  -height => 100,
  -label => 'Cadre HAUT',
)->pack( qw/ -side top -fill both -expand 1 / );
 
# NB Le Scroll est INdépendant
my $defil_v = $Wm->Scrollbar(
)->pack(qw/ -side right -fill y /);
 
my $cadre = $Wm->LabFrame(
  -width => 20,
  -height => 20,
  -label => 'Pour voir',
)->pack( qw/ -side bottom -fill both -expand 0 / );
 
my $casesG = $cadre->LabFrame(
	-background => $couleur_commune,
	-relief      => 'groove',
	-width => 60 ,
	-label      => 'Cases gauches',
);
 
my $lignes = $cadre->LabFrame(
	-background => $couleur_commune,
	-relief      => 'groove',
	-width => 10 ,
	-label      => 'Lignes',
);
 
my $casesD = $cadre->LabFrame(
	-background => $couleur_commune,
	-relief      => 'groove',
	-width => 60 ,
	-label      => 'Cases droites',
);
 
# $cadre contient :
# Deux cadres G & D qui vont contenir plusieurs lignes de cases
# séparés par une colone qui contient le n° de ligne
$cadre->pack(qw / -side bottom -fill both -expand 1 /);
$casesG->pack(qw / -side left -fill both -expand 1 /);
$lignes->pack(qw / -side left -fill both -expand 1 /);
$casesD->pack(qw / -side left -fill both -expand 1 /);
 
# cadre et listes doivent communiquer avec la barre
$defil_v->configure( -command => sub {
	[$cadre->yview(@_)],
  [$casesG->yview(@_)],
  [$lignes->yview(@_)],
  [$casesD->yview(@_)],
  }
);
 
# Lignes dans cadres
for ( my $numlig = 1 ; $numlig < $NB_LIG; $numlig++ ){
	#CasesG
	$lig_casesG[$numlig] = $casesG->Label (
  	-width => 2 ,
  	-background  => '#AAE0D0',
  	-height => 1, )->pack(qw / -side bottom								
  														-fill x
  														-expand 0 /);
  	$defil_v->configure( -command => sub { [$lig_casesG[$numlig]->yview(@_)] } );
 
  	for ( my $numcol = 1 ; $numcol < $NB_COL; $numcol++ ){
  		$CaseG[$numlig][$numcol] = $lig_casesG[$numlig]->Label (
  			-textvariable => \$tab[$numcol],
  			-width => 2 ,
  			-background  => '#AAE0D0',
  			-height => 1, )->pack(qw / -side left
  														-fill x
  														-expand 0 /);
  		$defil_v->configure( -command => sub { [$CaseG[$numlig][$numcol]->yview(@_)] } );
  	}
 
  #lignes
	$lig_lig[$numlig] = $lignes->Label (
  	-width => 2 ,
  	-background  => '#AAE0D0',
  	-height => 1, )->pack(qw / -side bottom								
  														-fill x
  														-expand 0 /);
  	$defil_v->configure( -command => sub { [$lig_lig[$numlig]->yview(@_)] } );
 
  	for ( my $numcol = 1 ; $numcol < 2; $numcol++ ){
  		$Lig[$numlig][$numcol] = $lig_lig[$numlig]->Label (
  			-textvariable => \$tab[$numlig],
  			-width => 2 ,
  			-background  => '#AAE0D0',
  			-height => 1, )->pack(qw / -side left
  														-fill x
  														-expand 0 /);
  		$defil_v->configure( -command => sub { [$Lig[$numlig][$numcol]->yview(@_)] } );
  	}
 
  #CasesD
	$lig_casesD[$numlig] = $casesD->Label (
  	-width => 2 ,
  	-background  => '#AAE0D0',
  	-height => 1, )->pack(qw / -side bottom								
  														-fill x
  														-expand 0 /);
  	$defil_v->configure( -command => sub { [$lig_casesD[$numlig]->yview(@_)] } );
 
  	for ( my $numcol = 1 ; $numcol < $NB_COL; $numcol++ ){
  		$CaseD[$numlig][$numcol] = $lig_casesD[$numlig]->Label (
  			-textvariable => \$tab[$numcol],
  			-width => 2 ,
  			-background  => '#AAE0D0',
  			-height => 1, )->pack(qw / -side left
  														-fill x
  														-expand 0 /);
  		$defil_v->configure( -command => sub { [$CaseD[$numlig][$numcol]->yview(@_)] } );
  	}
 
}
 
$CaseG[1][1]->configure(
		-background => '#FFE0D0',
);
 
$CaseD[5][5]->configure(
		-background => '#FFE0D0',
);
 
MainLoop();

Dans Introduction à Perl Tk 6-Barres de défilement p134, il est précisé que les barres fonctionnent avec les boîtes de liste, les canevas, les zones de saisie, les listes et les damiers, mais que ces derniers ne sont pas traités.

Le premier exemple qui fonctionne presque me laisse penser que ce que j'ai fait n'est pas impossible et qu'il n'y aurait qu'un réglage du rafraîchissement à réaliser... pourtant lorsque je diminue le nombre de colonnes il n'y a aucune amélioration ?

Auriez-vous quelques pistes ?
N'y passez pas vos nuits, c'est juste pour occuper mon neurone
MERCI !

[dmganges]

C'est une ânerie !
Dans la précipitation j'ai collé des scrolls à une Frame... çà me semblait naturel
Comme çà fonctionnait ""presque"" je me suis embarqué dans une mauvaise direction.

Pour faire un vrai damier scrollable il vaut mieux passer par Canvas.

Je fais donc mes premiers pas dans Canvas et je découvre qu'il gère mieux les chaînes arabes.
Donc la bataille navale çà sera pour plus tard, je retourne à mon sujet initial, moins potache :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
#!/usr/bin/perl
use warnings;
use strict;
use utf8;
use Tk;
use Tk::ROText;
 
my $Wm =  new MainWindow();
$Wm->geometry("1000x500+100+100");
 
my $midframe = $Wm->Frame(-bg=>'grey45')->pack();
my $midframel = $midframe->Frame(-bg=>'grey45')
                   ->pack(-side=>'left',-expand=>1,-fill=>'y');
my $midframer = $midframe->Frame(-bg=>'grey45')
             ->pack(-side=>'right');
 
# Scrolled qui affiche le texte
my $widget_text_cours = $midframer->Scrolled(
  'ROText',
  -scrollbars => 'e',
  -takefocus  => 0,
  -wrap      => 'word',
  -relief    => 'flat',
  -background => '#ABFAA3',
);
$widget_text_cours->pack(qw / -side top -fill both -expand 1 /);
configurer_tags($widget_text_cours);
 
my $canvasp;
 
#for canvasp and yscroll
my $midframer1 = $midframer->Frame(-bg=>'grey45')
                   ->pack(-side=>'top');
 
my $yscroll = $midframer1->Scrollbar( 
       -orient  => 'vertical',
       -command => \&yscrollit,
       -troughcolor =>'grey45',
       -activebackground =>'lightseagreen',
       -background => 'lightseagreen',
       )->pack(-side=>'right',-fill=>'y');
 
#canvas qui affiche le texte
$canvasp = $midframer1->Canvas(
             -bg =>'lightsteelblue',
             -width=>1400,
             -height=> 700,
             -scrollregion=>[0,0,1400,700],
      				-yscrollincrement => 1,
             -yscrollcommand => [ 'set', $yscroll ],
	     ) ->pack(-side=>'left');#,-fill=>'both');
 
my $texte = "فَصُولُ  السَّنَة  : الرَّبِيع   الصَّيْف   الْخَرِيف   السِّتَاء";
my $font = 0;
$font = $font + 36;
 
$widget_text_cours->insert( 'end', "\n", "g12" );
$widget_text_cours->insert( 'end', "Le texte dans Scrolled Text se fragmente\n si on clique dessus avec la souris\n", "g36" );
$widget_text_cours->insert( 'end', $texte, "g36" );
$widget_text_cours->insert( 'end', "\n", "g12" );
 
$canvasp->createText(0,60,
	-width=>1300,
	-anchor => "w",
	-justify => "left",
	-font      => '{Simplified Arabic} 36 {bold}',
	-text => "Le texte dans Canvas ne se fragmente pas au clic de la souris\n",
);
 
$canvasp->createText(1900,200,
	-width=>1900,
	-anchor => "e",
	-justify => "right",
	-font      => '{Simplified Arabic} 36 {bold}',
	-text => $texte,
);
 
 
#---------------------------------------------------------------
MainLoop;
################################################################
 
sub xscrollit{
 my $fraction = $_[1];
 $canvasp->xviewMoveto($fraction);
}
################################################################
sub yscrollit{
  my $fraction = $_[1];
  $canvasp->yviewMoveto($fraction);
}
################################################################
 
#########################################
# Configuration des polices de caractères
#
sub configurer_tags {
	my $widget_text = shift;
	for my $police ( 12 .. 72 ) {
		if ( $police % 2 == 0 ) {
			$widget_text->tagConfigure(
				"g$police",
				-background => '#ABFAA3',
				-font      => "{Simplified Arabic} $police {bold}",
				-justify    => 'center',
			);
		}
	}
}

@+ si je m'en sors avec la gestion des indices dans le canvas...