| 1 | # bounce.pl |
| 2 | |
| 3 | use Ball; |
| 4 | use Tk qw/:eventtypes/; |
| 5 | use subs qw/ClearMsg DoSingleStep NotDone ShowMsg SimStart SimStop mkmb/; |
| 6 | use vars qw/$TOP/; |
| 7 | |
| 8 | my(@menu_button_list, $quit_flag, $quit_code, |
| 9 | $bounce_status, $bounce_speed, $bounce_running, $bounce_counter); |
| 10 | |
| 11 | sub bounce { |
| 12 | |
| 13 | # This began as a borrowed idea from Python distribution examples, ended up |
| 14 | # with a Ball module of its own. It illustrates how one can run something |
| 15 | # without blocking XEvent processing in a simple-minded sorta way. |
| 16 | # |
| 17 | # Handles resizes to the main window |
| 18 | # |
| 19 | # Gurusamy Sarathy (gsar@engin.umich.edu) |
| 20 | # Tidied up by SOL. |
| 21 | # |
| 22 | # 97/06/10 This demo is sufficiently bizarre enough that we don't use |
| 23 | # WidgetDemo! (-: Plus, you get to see Exists() in action. |
| 24 | |
| 25 | my($demo) = @_; |
| 26 | |
| 27 | $TOP->destroy if Exists($TOP); |
| 28 | $TOP = $MW->Toplevel; |
| 29 | $TOP->title('Bouncing Ball Simulator'); |
| 30 | $TOP->iconname('bounce'); |
| 31 | |
| 32 | @menu_button_list = (); |
| 33 | $quit_flag = 0; |
| 34 | $quit_code = sub {$quit_flag = 1}; |
| 35 | $TOP->protocol('WM_DELETE_WINDOW' => $quit_code); |
| 36 | |
| 37 | my $menubar = $TOP->Frame(qw/-relief raised -background DarkGreen -bd 2/); |
| 38 | $menubar->pack(-side => 'top', -fill => 'x'); |
| 39 | |
| 40 | mkmb($menubar, 'File', 0, 'File related stuff', |
| 41 | [ |
| 42 | ['Open', \&NotDone, 0], |
| 43 | ['New', \&NotDone, 0], |
| 44 | ['Print', \&NotDone, 0], |
| 45 | ['Exit', sub{$TOP->bell}, 0], |
| 46 | ]); |
| 47 | |
| 48 | mkmb($menubar, 'Simulate', 0, 'Simulator control', |
| 49 | [ |
| 50 | ['Start', \&SimStart, 2], |
| 51 | ['Stop', \&SimStop, 2], |
| 52 | ]); |
| 53 | |
| 54 | mkmb($menubar, 'Display', 0, 'Display settings', |
| 55 | [ |
| 56 | ['Redraw', \&NotDone, 2], |
| 57 | ['Clear', \&NotDone, 2], |
| 58 | ]); |
| 59 | |
| 60 | mkmb($menubar, 'Options', 0, 'Various preferences', |
| 61 | [ |
| 62 | ['Steptime', \&NotDone, 0], |
| 63 | ['Colors', \&NotDone, 0], |
| 64 | ['Display', \&NotDone, 0], |
| 65 | ]); |
| 66 | |
| 67 | mkmb($menubar, 'Help', 0, 'There when you need it', |
| 68 | [ |
| 69 | ['About..', \&NotDone, 0], |
| 70 | ['Intro', \&NotDone, 0], |
| 71 | ['Contents', \&NotDone, 0], |
| 72 | ]); |
| 73 | $menu_button_list[$#menu_button_list]->pack(-side => 'right'); |
| 74 | |
| 75 | my $feedback = $TOP->Frame(); |
| 76 | $feedback->pack(-side => 'bottom', -fill => 'x'); |
| 77 | $bounce_status = $feedback->Text( |
| 78 | -relief => 'sunken', |
| 79 | -height => 1, |
| 80 | -background => 'gray', |
| 81 | -borderwidth => 2, |
| 82 | ); |
| 83 | $bounce_status->pack(-side => 'left', -fill => 'x', -expand => 1); |
| 84 | |
| 85 | my $drawarea = $TOP->Frame(); |
| 86 | $drawarea->pack(-side => 'top', -fill => 'both', -expand => 1); |
| 87 | |
| 88 | my $canvas = $drawarea->Canvas( |
| 89 | -relief => 'ridge', |
| 90 | -height => 400, |
| 91 | -width => 600, |
| 92 | -borderwidth => 2, |
| 93 | ); |
| 94 | $canvas->pack(-side => 'left', -fill => 'both', -expand => 1); |
| 95 | |
| 96 | $bounce_speed = $drawarea->Scale( |
| 97 | -orient => 'vert', |
| 98 | -showvalue => 0, |
| 99 | -width => 10, |
| 100 | -from => 100, |
| 101 | -to => 0, |
| 102 | -borderwidth => 1, |
| 103 | ); |
| 104 | $bounce_speed->pack(-side => 'left', -fill => 'y'); |
| 105 | $bounce_speed->bind('<Enter>' => sub { |
| 106 | ClearMsg; ShowMsg('Adjust slider for ball speed'); |
| 107 | }); |
| 108 | $bounce_speed->bind('<Leave>' => \&ClearMsg); |
| 109 | $bounce_speed->set(50); |
| 110 | |
| 111 | my $w_buttons = $TOP->Frame; |
| 112 | $w_buttons->pack(qw(-side bottom -expand y -fill x -pady 2m)); |
| 113 | my $w_dismiss = $w_buttons->Button( |
| 114 | -text => 'Dismiss', |
| 115 | -command => $quit_code, |
| 116 | ); |
| 117 | $w_dismiss->pack(qw(-side left -expand 1)); |
| 118 | my $w_see = $w_buttons->Button( |
| 119 | -text => 'See Code', |
| 120 | -command => [\&see_code, $demo], |
| 121 | ); |
| 122 | $w_see->pack(qw(-side left -expand 1)); |
| 123 | my $w_ball = $w_buttons->Button( |
| 124 | -text => 'View Ball Class Module', |
| 125 | -command => [\&view_widget_code, |
| 126 | Tk->findINC('demos/widget_lib') . '/Ball.pm'], |
| 127 | ); |
| 128 | $w_ball->pack(qw(-side left -expand 1)); |
| 129 | |
| 130 | $bounce_running = 0; |
| 131 | $menu_button_list[1]->cget(-menu)->entryconfigure(1, -state => 'disabled'); |
| 132 | |
| 133 | $canvas->Ball; |
| 134 | $canvas->Ball(-color => 'red', -size => 30, -position => [200, 75]); |
| 135 | $canvas->Ball( |
| 136 | -color => 'green', |
| 137 | -size => 60, |
| 138 | -position => [490, 275], |
| 139 | -velocity => [8.0, 12.0], |
| 140 | ); |
| 141 | $canvas->Ball( |
| 142 | -color => 'yellow', |
| 143 | -size => 100, |
| 144 | -position => [360, 60], |
| 145 | -velocity => [8.0, 12.0], |
| 146 | ); |
| 147 | |
| 148 | $bounce_counter = 0; |
| 149 | $TOP->repeat(1000 => sub { |
| 150 | return unless $bounce_running; |
| 151 | ClearMsg; |
| 152 | ShowMsg(sprintf("%6d interations/second", $bounce_counter)); |
| 153 | $bounce_counter = 0 |
| 154 | }); |
| 155 | |
| 156 | |
| 157 | # This runs the Tk mainloop. Note that the simulation itself has a main |
| 158 | # loop which must be processed. DoSingleStep runs a bit of the simulation |
| 159 | # during every iteration. Also note that, with a flag of 0, |
| 160 | # Tk::DoOneEvent will suspend the process until an X-event arrives, |
| 161 | # effectively blocking the while loop. |
| 162 | # |
| 163 | # My original idea was to run the simulation mainloop as an asynchronous |
| 164 | # proc handler that runs when Tk is idle, but the necessary Async(3) calls |
| 165 | # from Tcl haven't made it into nTk yet. |
| 166 | |
| 167 | while (1) { |
| 168 | if ($quit_flag) { |
| 169 | $TOP->destroy; |
| 170 | return; |
| 171 | } |
| 172 | DoOneEvent($bounce_running ? DONT_WAIT : ALL_EVENTS); |
| 173 | DoSingleStep($canvas) if $bounce_running; |
| 174 | } |
| 175 | |
| 176 | } # end bounce |
| 177 | |
| 178 | sub mkmb { |
| 179 | |
| 180 | # (Ripped from nTk examples) |
| 181 | # Make a Menubutton widget; note that the menu is automatically created. |
| 182 | # We maintain a list of the Menubutton references since some callers |
| 183 | # need to refer to the Menubutton, as well as to suppress stray name |
| 184 | # warnings with Perl -w. |
| 185 | |
| 186 | my($mb0, $mb_label, $mb_label_underline, $mb_msg, $mb_list_ref) = @_; |
| 187 | my $mb = $mb0->Menubutton( |
| 188 | -text => $mb_label, |
| 189 | -underline => $mb_label_underline, |
| 190 | -background => 'DarkGreen', |
| 191 | -foreground => 'Yellow', |
| 192 | ); |
| 193 | my($menu) = $mb->Menu(-tearoff => 0); |
| 194 | $mb->configure(-menu => $menu); |
| 195 | |
| 196 | my $mb_list; |
| 197 | foreach $mb_list (@{$mb_list_ref}) { |
| 198 | $mb->command( |
| 199 | -label => $mb_list->[0], |
| 200 | -command => $mb_list->[1] , |
| 201 | -underline => $mb_list->[2], |
| 202 | -background => 'DarkGreen', |
| 203 | -foreground => 'White', |
| 204 | ); |
| 205 | } |
| 206 | $mb->pack(-side => 'left'); |
| 207 | $TOP->bind($mb, '<Enter>' => sub {ClearMsg; ShowMsg($mb_msg)}); |
| 208 | $TOP->bind($mb, '<Leave>' => \&ClearMsg); |
| 209 | |
| 210 | push @menu_button_list, $mb; |
| 211 | return $mb; |
| 212 | |
| 213 | } # end mkmb |
| 214 | |
| 215 | sub SimStart { |
| 216 | |
| 217 | if (not $bounce_running) { |
| 218 | $bounce_running = 1; |
| 219 | $menu_button_list[1]->cget(-menu)->entryconfigure(0, |
| 220 | -state => 'disabled', |
| 221 | ); |
| 222 | $menu_button_list[1]->cget(-menu)->entryconfigure(1, |
| 223 | -state => 'normal', |
| 224 | ); |
| 225 | } |
| 226 | |
| 227 | } # end SimStart |
| 228 | |
| 229 | sub SimStop { |
| 230 | |
| 231 | if ($bounce_running) { |
| 232 | $bounce_running = 0; |
| 233 | $menu_button_list[1]->cget(-menu)->entryconfigure(0, |
| 234 | -state => 'normal', |
| 235 | ); |
| 236 | $menu_button_list[1]->cget(-menu)->entryconfigure(1, |
| 237 | -state => 'disabled', |
| 238 | ); |
| 239 | } |
| 240 | |
| 241 | } # end SimStop |
| 242 | |
| 243 | sub NotDone { |
| 244 | |
| 245 | print "Not yet implemented.\n"; |
| 246 | |
| 247 | } # end NotDone |
| 248 | |
| 249 | sub ShowMsg { |
| 250 | |
| 251 | my($msg) = shift; |
| 252 | $bounce_status->insert('1.0', $msg); |
| 253 | |
| 254 | } # end ShowMsg |
| 255 | |
| 256 | sub ClearMsg { |
| 257 | |
| 258 | $bounce_status->delete('1.0', 'end'); |
| 259 | |
| 260 | } # end ClearMsg |
| 261 | |
| 262 | sub DoSingleStep { |
| 263 | |
| 264 | # The simulation handler. |
| 265 | # |
| 266 | # Note that this handler must be cooperative and return after a short |
| 267 | # period, so that other X events may be processed by the mainloop below. |
| 268 | |
| 269 | my($canvas) = @_; |
| 270 | |
| 271 | $bounce_counter++; |
| 272 | Ball->move_all_balls($canvas, $bounce_speed->get() / 100.0); |
| 273 | |
| 274 | } # end DoSingle Step |