http://qs321.pair.com?node_id=671958


in reply to "Rubics Cube" game

#--------------------------------------------------------------------- package main; #--------------------------------------------------------------------- sub init { # {{{1 $zug = ""; undef $mm; $mm = new matob(1); undef $qb; $qb = new qb($qbCubes, 1); $qb->updSlices(); $qb->{actAxis} = 'y'; print $qb->{cube},"\n"; my $font = '-misc-fixed-medium-r-normal-*-*-150-*-*-c-*-iso8859-9 +'; $font = '-misc-fixed-medium-r-*-*-13-*-*-*-m-*-*-*'; my $font2 = '-*-console-medium-*-*-*-16-*-*-*-*-*-*-*' +; $font2 = '-*-courier-medium-r-*-*-14-*-*-*-*-*-*-*'; my $al = 26; my $xAxis = new line3d( new point3d(-$al, 0, 0), new point3d($al, 0, 0) +, 1, "gray20", "xAxis"); my $yAxis = new line3d( new point3d(0, -$al, 0), new point3d(0, $al, 0) +, 1, $rgb{DarkRed}, "yAx +is"); my $zAxis = new line3d( new point3d(0, 0, -$al), new point3d(0, 0, $al) +, 1, "blue", "zAxis"); my $horiz = new vec3d( new point3d(1, 0, 0), 1, "green", "vektor"); my $vertik = new vec3d(new point3d(0, 1, 0), 1, "orange", "vektor") +; my $cvac = new vec3d($qb->{cube}[$actCube]{centr}, 1, "white", "cvac"); # all vars should be kept in a common ds { cvac => $cvac, freezeCvac => 0, font => [$font, $font2] +, horiz => $horiz, old_fill => '', PFLAG => 1, plotCS => 0, plotTri => 0, triX => 0, triY => 0, triZ => 0, showCvac => 1, shuffleSteps => 1, vertik => $vertik, xAxis => $xAxis, xb1down => 0, xb3down => 0, yAxis => $yAxis, yb1down => 0, yb3down => 0, zAxis => $zAxis, } } # init }}}1 my $V = init(); sub plotAllVectors { #{{{1 $V->{showCvac} && $V->{cvac}->plot; $V->{horiz}->plot; $V->{vertik}->plot; #$c20_centr->plot; }; #}}}1 sub plotAll { #{{{1 #print "plotte mal wieder all\n";; $qb->plotAllCubes; plotCS() if $V->{plotCS}; plotTri() if $V->{plotTri}; # plotAllVectors; } # plotAll #}}}1 sub plotCS { #{{{1 $V->{xAxis}->plot; $V->{yAxis}->plot; $V->{zAxis}->plot; } # plotCS #}}}1 sub remCS { #{{{1 $V->{xAxis}->clear; $V->{yAxis}->clear; $V->{zAxis}->clear; } # remCS #}}}1 sub plotTri { #{{{1 $V->{triX}->plot; $V->{triY}->plot; $V->{triZ}->plot; } # plotCS #}}}1 sub remTri { #{{{1 $V->{triX}->clear; $V->{triY}->clear; $V->{triZ}->clear; } # remCS #}}}1 sub fileDialog { #{{{1 my $w = shift; my $operation = shift; my $file; # Type names Extension(s) Mac File Type(s) # #--------------------------------------------------------- my @types = ( ["qb3-Snapshot files", '.qsn'], ["qb3-Moves files", '.qmv'], ["qb3 files (deprecated)", '.qb3'], #["All files", '*'] ); if ($operation eq 'open') { $file = $w->getOpenFile(-filetypes => \@types); } else { $file = $w->getSaveFile(-filetypes => \@types, -initialfile => 'noname', #-defaultextension => '.qb3'); ); } $file; #if (defined $file and $file ne '') { # $ent->delete(0, 'end'); # $ent->insert(0, $file); # $ent->xview('end'); #} } # fileDialog }}}1 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Widgets and bindings # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # Menus {{{1 my $top = MainWindow->new(); $top->resizable(1, 1); # Menu Bar # {{{2 my $menu_bar = $top ->Frame( -relief => 'raise', -borderwidth => 2) ->pack(-side => 'top', -fill => 'x'); #}}}2 # Game Menu # {{{2 my $menuB1 = $menu_bar ->Menubutton(-text => 'Game') ->pack(-side => 'left', -padx => 2); $menuB1->command( -label => 'New', -accelerator => 'Ctrl-n', -underline => 0, -command => \&newGame, ); $top->bind('<Control-n>' => \&newGame); $menuB1->separator(); $menuB1->command( -label => 'Load', -accelerator => 'Ctrl-l', -underline => 0, -command => \&load, ); $menuB1->command( -label => 'Save as', -accelerator => 'Ctrl+s', -underline => 0, -command => \&save, ); $menuB1->separator(); $menuB1->command( -label => 'Quit', -accelerator => 'q', -underline => 0, -command => \&lebWohl, ); #}}}2 # Dialogs Menu # {{{2 use subs qw/colMenu moveInp/; # 040930: Menubutton's menuitems expects a list-of-list- # reference. It doesn't matter whether this reference # is delivered by list-reference or via sub. my $diaMenu = [ ['cascade', "Colors", -menuitems => colMenu], ['command', 'MoveInput', -command => \&moveInp], ['command', 'checkSlices', -command => \&checkSlices], ]; #sub diaMenu { # [ # ['cascade', "Colors", -menuitems => colMenu], # ], #} my $menuB4 = $menu_bar ->Menubutton( -text => 'Dialogs', -menuitems => $diaMenu) ->pack(-side => 'left', -padx => 2); #my $menuB4 = $menu_bar # ->Menubutton( -text => 'Colors', # -menuitems => colMenu) # ->pack(-side => 'left', -padx => 2); # # the Slick, Sophisticated, New-Fashioned Way, # -> 12.2.2. masteringPerlTk\ch12_02.h +tm # # auf die folgende Art läßt sich sehr elegant das kaskadierende # Farbmenu erzeugen. sub colMenu { #{{{3 [ ['command', 'default', -command => sub { foreach (keys %cD) { $menuB4->entryconfigure ($_, -background => $cD{$_}[0]); %cL = %cD; plotAll(); } } ], map ['cascade', $_, -background => $cL{$_}[0], -menuitems => [ map ['command', $_, -background => $rgb{$_}, -command => [ sub { print "\$_: $_\n"; print "\$menuB4: $menuB4\n"; # nachdem das colMenu ein Stufe tiefer + ge- # rutscht ist, kann ich den index des +ersten # col-Menus nicht mehr ermitteln. ?! # bekomme nur 'none'. Lösung vermutlic +h dann, # wenn ich die folgende Zeile tatsächl +ich ver- # standen und anschließend modifiziert + habe. # don't give up ... # bis v0.52 funktioniert colMenu; alle +rdings # auf höherer Menustufe my $i1 = $menuB4->menu()->index("activ +e"); my $i2 = shift @_; print "$i1/$i2\n"; my $i3 = index ("yelredoragreblupin", +$i2)/3; print "\$i3: $i3\n"; my $i4 = $i1 - 1; $cL{"r$i4"} = $cRef->[$i3]; $menuB4->entryconfigure($i1, -background => $rgb{$i +2}); plotAll(); }, $_ ], ], qw/yel red ora gre blu pin/, ], ], qw/r1 r2 r3 r4 r5 r6/, ], } # end colMenu }}}3 sub moveInp { #{{{3 if (! Exists($tl)) { $tl = $top->Toplevel( ); $tl->title("MoveInput"); my $text = $tl->Scrolled('Text', -width => 25, -height => 10, -scrollbars => 'w')->pack(qw/ -fill y -e +xpand 1/); $tl->Button(-text => "Clear", -command => sub { $text->delete("1.0", "end"); } )->pack(-side => 'left'); $tl->Button(-text => "Commit", -command => sub { my @z = split /\n/, $text->get("1.0", "end"); foreach (@z) { /([xyz]\d)([+-]?\d)/ ? do { my $z = "$1$2"; print "tue $z\n"; $qb->move($z); } : print "invalid Move\n"; }; } )->pack(-side => 'left'); $tl->Button(-text => "HighLightCubes", -command => sub { my @z = split /\n/, $text->get("1.0", "end"); foreach (@z) { /(\d\d)/ && print $1,"\n"; $qb->{cube}[$1]->{palette} = 4; }; plotAll(); } )->pack(-side => 'left'); $tl->Button(-text => "Close", -command => sub { $tl->withdraw } )->pack(-side => 'left'); } else { $tl->deiconify( ); $tl->raise( ); } } # end moveInp #}}}3 sub checkSlices { #{{{3 if (! Exists($tlcs)) { $tlcs = $top->Toplevel( ); $tlcs->title("checkSlices"); # setup the default value we would like my $rb_value = "gray"; $tlcs->configure(-background => $rb_value); # create the Radiobuttons that will let us change it foreach (qw(x y z)) { my $fr = $tlcs->Frame( -borderwidth => 2, #-relief => 'ridge', )->pack(qw/-side left/); for (my $i = 1; $i <= $qbCubes; $i++) { $fr->Radiobutton( -text => $_ . $i, -value => $_ . $i, -variable => \$rb_value, -command => \&set_bg)->pack(-side => 'top'); } } sub set_bg { foreach (0 .. $qbCubes ** 3 - 1) { $qb->{cube}[$_]->{palette} = 0; }; plotAll(); #print "\$rb_value: $rb_value\n"; foreach (keys %{$qb->{slice}{$rb_value}{members}}) { $qb->{cube}[$_]->{palette} = 1; }; plotAll(); } $tlcs->Button(-text => "Clear", -command => sub { foreach (0 .. $qbCubes ** 3 - 1) { $qb->{cube}[$_]->{palette} = 0; }; plotAll(); } )->pack(-fill => 'y', -expand => 1, -side => 'top'); $tlcs->Button(-text => "Close", -command => sub { $tlcs->withdraw } )->pack(-side => 'bottom'); } else { $tlcs->deiconify( ); $tlcs->raise( ); } } # end moveInp #}}}3 # }}}2 # Options Menu # {{{2 my $mOptions = $menu_bar ->Menubutton(-text => 'Options') ->pack(-side => 'left', -padx => 2); $mOptions->separator; my $cubeMenu = $mOptions->cget(-menu)->Menu(); $mOptions->cascade(-label => "cubes", -underline => 0, -menu => $cubeMenu); foreach (qw/2 3 4 5/) { $cubeMenu->radiobutton( -label => $_, -variable => \$qbCubes, ); } $mOptions->checkbutton( -label => 'show cvac', -variable => \$V->{showCvac}); $mOptions->checkbutton( -label => 'freeze cvac', -variable => \$V->{freezeCvac}); $mOptions->separator; my $shufMenu = $mOptions->cget(-menu)->Menu(); $mOptions->cascade(-label => "shuffleSteps", -underline => 0, -menu => $shufMenu); $shufMenu->radiobutton(-label => '3', -variable => \$V->{shuffleSteps}); $shufMenu->radiobutton(-label => '5', -variable => \$V->{shuffleSteps}); $shufMenu->radiobutton(-label => '9', -variable => \$V->{shuffleSteps}); $shufMenu->radiobutton(-label => '20', -variable => \$V->{shuffleSteps}); $shufMenu->radiobutton(-label => '50', -variable => \$V->{shuffleSteps}); # }}}2 # "Questionmark"-menu {{{2 my $qmMenu = $menu_bar ->Menubutton(-text => '?') ->pack(-side => 'left', -padx => 2); $qmMenu->command( -label => 'Help', -accelerator => 'Meta+H', -underline => 0, -command => sub {print "hilf dir selbst da +nn \ hilft +dir gott...\n"} ); sub mbox { my $mbox = $top->DialogBox( -title => "About qb3", -buttons => ["ok"], ); my $fr = $mbox->add('Frame', -borderwidth => 2, -relief => 'ridge') ->pack(qw/-side left/); $fr->Label(-image => $mbox->Pixmap( -data => &greyCubeLogo)) ->pack(qw/-side top/); $mbox->add('Label', -text => " Version: $VERSION\n\n" . "Perl: $]\n" . "Tk : $Tk::VERSION", -relief => "groove", )->pack(-side => 'left'); $mbox->add('Label', -image => $top->Pixmap(-data => &ptk)) ->pack(qw/-side top/); $mbox->add('Label', -image => $top->Pixmap(-data => &cwVim)) ->pack(qw/-side top/); $mbox->add('Label', -image => $top->Pixmap(-data => &wilbur)) ->pack(qw/-side top/); $mbox->add('Label', -image => $top->Pixmap(-data => &tos), -relief => "groove", )->pack(qw/-side top/); $mbox->add('Label', -text => " made by tos", -relief => "groove", )->pack(-side => 'top'); $mbox->Show(); }; #}}}2 sub show_msg { #{{{1 my($iconvar, $message, $movLBox) = @_; my $button = $top->messageBox( -icon => $iconvar, -type => "OK", -title => 'Message', -message => $message ); #$saveIt && $qb->save("errDump", $movLBox); exit; } # show_msg }}}1 $qmMenu->command( -label => 'About', -accelerator => 'Meta+A', -underline => 0, -command => \&mbox, ); # }}}2 # menus }}}1 # dashboard {{{1 my $mainFrame = $top ->Frame(-bd => "2") ->pack(-side => 'top', -fill => 'x'); my $rf = $mainFrame ->Frame( -bd => "2", #-cursor => 'rtl_logo', #-cursor => 'question_arrow', #-cursor => 'draped_box', -cursor => 'plus', ) ->pack(-side => 'right', -fill => 'y'); my $tf = $mainFrame ->Frame() ->pack(-side => 'top', -fill => 'both'); my $cubAnz1 = $tf ->Label( -text => "", #-relief => "groove", -width => 30, -foreground => $rgb{Dark +Green}, -height => 4, -font => $V->{font}[0]) ->pack(-fill => 'x', -expand => 1, -side => 'left' +); my $bf = $mainFrame ->Frame() ->pack(-side => 'bottom', -fill => 'x'); my $cubAnz2 = $bf ->Label( -text => "", #-relief => "groove", -foreground => $rgb{DarkGreen}, -height => 4, -font => $V->{font}[0]) ->pack(-fill => 'x', -expand => 1, -side => 'left' +); my $lf = $mainFrame ->Frame( #-relief => "groove", -cursor => 'plus', -bd => "2") ->pack(-side => 'left', -fill => 'y'); my $tlf = $lf ->Frame( #-relief => "groove", -bd => "2") ->pack(-side => 'top', -fill => 'x'); my $blf = $lf ->Frame( #-relief => "groove", -bd => "2") ->pack(-side => 'bottom', -fill => 'x'); $top->Icon(-image => $top->Pixmap(-data => &icon)); my $hMovLBox = $tlf ->Label( -text => "Moves", -relief => "flat", -foreground => "gray20", -cursor => 'pirate', #-width => 10, -font => $V->{font}[0]) ->pack(-side => 'top', -fill => 'x'); my $movLBox = $tlf ->Scrolled(qw/Listbox -width 16 -height 7 -setgrid 1 -scrollbars w -bd 2/, -font => $V->{font}[1]) ->pack(); #-bg LemonChiffon2 /, my $canvFram = $mainFrame ->Frame( #-relief => "groove", -width => 600, -height => 270, -bd => "2") ->pack(-side => 'left'); $canvas = $canvFram ->Canvas(-width => $screenWidth, -height => $screenHeight, #-relief => "ridge", -cursor => 'crosshair') ->pack(-side => 'left', -fill => 'both'); my $detInf = $rf ->Frame( ) ->pack(-side => 'right', -fill => 'both'); my $statLine = $top ->Frame( -relief => "raise", -bd => "2", -heigh +t => 8) ->pack(-side => 'top', -fill => 'both'); my $statAnz = $top ->Frame( -relief => "sunken", -bd => "2", -foreground => $rgb{DarkGreen}) ->pack(-side => 'top', -fill => 'x'); my $lvFrame = $detInf ->Frame( -relief => "flat", -bd => "2") ->pack(-side => 'top', -fill => 'x'); my $wvFrame = $detInf ->Frame( -relief => "flat", -bd => "2") ->pack(-side => 'top', -fill => 'x'); my $dFrame = $detInf ->Frame( -relief => "flat", -bd => "2") ->pack(-side => 'top', -fill => 'x'); my $oFrame = $detInf ->Frame( -relief => "flat", -bd => "2") ->pack(-side => 'top', -fill => 'x'); my $sVFrame = $detInf ->Frame( -relief => "flat", -bd => "2") ->pack(-side => 'top', -fill => 'x'); my $rfDeckl = $detInf ->Label( -relief => "flat", -width => "50", -height => "40", -text => "") ->place(-x => 0, -y => 0); my $tlfDeckl = $tlf ->Label( -relief => "flat", -width => "50", -height => "20", -text => "") ->place(-x => 0, -y => 0); my $blfDeckl = $blf ->Label( -relief => "flat", -width => "50", -height => "20", -text => "") ->place(-x => 0, -y => 0); my $lvLab = $lvFrame ->Label( -text => "localCoords", -relief => "flat", -cursor => 'pirate', -foreground => "gray20", -width => 20, -font => $V->{font}[0]) ->pack(-side => 'top'); my $lxAnz = $lvFrame ->Label( -text => "", -relief => "sunken", -foreground => "gray20", -width => 10, -font => $V->{font}[0]) ->pack(-side => 'top'); my $lyAnz = $lvFrame ->Label( -text => "", -relief => "sunken", -foreground => $rgb{DarkRed}, -width => 10, -font => $V->{font}[0]) ->pack(-side => 'top'); my $lzAnz = $lvFrame ->Label( -text => "", -relief => "sunken", -foreground => $rgb{DarkBlue}, -width => 10, -font => $V->{font}[0]) ->pack(-side => 'top'); my $cubAnz = $statLine ->Label( -text => "", -relief => "sunken", -width => 3, -foreground => $rgb{DarkG +reen}, -font => $V->{font}[0]) ->pack(-side => 'left'); my $rectAnz = $statLine ->Label( -text => "", -relief => "sunken", -width => 2, -foreground => "blue", -font => $V->{font}[0]) ->pack(-side => 'left'); my $sliceAnz = $statLine ->Label( -text => "", -relief => "sunken", -width => 5, -foreground => "darkorchi +d", -foreground => "purple", -font => $V->{font}[0]) ->pack(-side => 'left'); my $vecAnz = $statLine ->Label( -text => "", -relief => "sunken", -width => 4, -foreground => "darkorchid", -font => $V->{font}[0]) ->pack(-side => 'left'); my $statFram = $statLine ->Frame( -relief => "groove", -bd => "1", #-height => 3) ) ->pack(-side => 'left', -fill => "x"); $statFram->bind('<1>' => sub { print "bye, bye Sir!\n"; exit; }); my $shuffle = $statFram ->Button(-text => "shuffle", -height => 0.3, -command => sub { keys %{$qb->{constraint}} && r +eturn; $qb->shuffle( $V->{shuff +leSteps}, $movLBox ); }, -font => $V->{font}[0]) ->pack(-side => 'left'); my $leave = $statFram ->Label( -text => "", -width => 40, -cursor => 'pirate', -font => $V->{font}[0]) ->pack(-side => 'left', -fill => 'x'); my $yKoor = $statLine ->Label( -text => "", -relief => "sunken", -width => 3, -font => $V->{font}[0]) ->pack(-side => 'right'); my $xKoor = $statLine ->Label( -text => "", -relief => "sunken", -width => 3, -font => $V->{font}[0]) ->pack(-side => 'right'); my $lwLab = $wvFrame ->Label( -text => "worldCoords", -relief => "flat", -foreground => "gray20", -width => 12, -font => $V->{font}[0]) ->pack(-side => 'top'); my $xKoor3d = $wvFrame ->Label( -text => "", -relief => "sunken", -width => 10, -foreground => "gray20", + -font => $V->{font}[0]) ->pack(-side => 'top'); my $yKoor3d = $wvFrame ->Label( -text => "", -relief => "sunken", -width => 10, -foreground => $rgb{Dark +Red}, -font => $V->{font}[0]) ->pack(-side => 'top'); my $zKoor3d = $wvFrame ->Label( -text => "", -relief => "sunken", -width => 10, -foreground => $rgb{Dark +Blue}, -font => $V->{font}[0]) ->pack(-side => 'top'); my $dLab = $dFrame ->Label( -text => "distance", -relief => "flat", -foreground => "gray20", -width => 12, -font => $V->{font}[0]) ->pack(-side => 'top'); my $distLab = $dFrame ->Label( -text => "", -foreground => "red", -relief => "sunken", -width => 10, -font => $V->{font}[0]) ->pack(-side => 'top'); my $oLab = $oFrame ->Label( -text => "query", -relief => "flat", -foreground => "gray20", -width => 12, -font => $V->{font}[0]) ->pack(-side => 'top'); my $rSentry = $oFrame ->Entry(-relief => "sunken", -width => 10, -textvariable => \$qb->{query}, -validate => 'key', -font => $V->{font}[0]) ->pack(-side => 'top'); my $sVLab = $sVFrame ->Label( -text => "selVect", -relief => "flat", -foreground => "gray20", -width => 12, -font => $V->{font}[0]) ->pack(-side => 'top'); my $sVxAnz = $sVFrame ->Label( -text => "", -relief => "sunken", -foreground => "gray20", -width => 10, -font => $V->{font}[0]) ->pack(-side => 'top'); my $sVyAnz = $sVFrame ->Label( -text => "", -relief => "sunken", -foreground => $rgb{DarkRed}, -width => 10, -font => $V->{font}[0]) ->pack(-side => 'top'); my $sVzAnz = $sVFrame ->Label( -text => "", -relief => "sunken", -foreground => $rgb{DarkBlue}, -width => 10, -font => $V->{font}[0]) ->pack(-side => 'top'); my $sVnAnz = $sVFrame ->Label( -text => "", -relief => "sunken", -foreground => "black", -width => 10, -font => $V->{font}[0]) ->pack(-side => 'top'); sub lebWohl { $top->iconify(); #$saveIt && $qb->save("noname", $movLBox); print "bye, bye Sir!\n"; exit; }; # lebWohl my $hiddenMB = $top->Menubutton( -text => 'File', -relief => 'raised', ); #$file->pack(qw/-side left/); my $hiddenM = $hiddenMB->Menu(-tearoff => 0, -menuitems => [ [qw/command ~color/], '', [qw/command ~position/], '', [qw/command ~properties/], '', [qw/command ~hide/], '', [qw/command ~Quit/, -command => \&exit], ]); $hiddenMB->configure(-menu => $hiddenM); #print "\$hiddenM: $hiddenM\n"; sub load { # {{{3 $canvas->configure(-cursor => 'watch'); my $file = shift || fileDialog($top, "open"); $file || return; #print "\$file: $file\n"; my ($name,$path,$ext) = fileparse($file, '\..*'); #print "\$name: $name\n"; #print "\$path: $path\n"; #print "\$ext: $ext\n"; print "loading ... "; $canvas->delete('all'); #local $/ = ""; CASE: { ($ext eq ".qsn") && do { my $ds; open I, $file; while (<I>) { m/\'id\'\s+\=\>\s+\d+/ && next; $ds .= $_; }; close I; eval $ds; }; ($ext eq ".qmv") && do { open I, $file; while (<I>) { #print; chomp; $movLBox->inser +t('end', $_); /([xyz]\d-?\d)/; my $haltMal = $1; #print "will $halt +Mal\n"; $qb->move($haltMal +); } close I; }; }; open (I, $path . $name . ".qpo"); my $ds = (<I>); print $ds; close I; eval $ds; print "done\n"; plotAll(); print "\$qb: $qb\n"; $canvas->configure(-cursor => 'crosshair'); }; # load }}}3 sub save { # {{{3 my $f = fileDialog($top, "save"); $qb->save($f, $movLBox) if defined $f; }; # save }}}3 sub newGame { # {{{3 $canvas->delete('all'); $movLBox->delete(0,'end'); $V = init(); $mm->rotate(PI/-6, PI/6, 0.0); plotAll(); }; #}}}3 # dashboard }}}1 # bindings # {{{1 my $labDefColor = $statLine->cget('-background'); my $highLightBgColor = "wheat2"; #$lyAnz->configure(-background => $highLightBgColor); sub updDashBoard { # {{{2 { ($qb->{actAxis} eq "x") && do { $lyAnz->configure(-background => $labDefColor); $lzAnz->configure(-background => $labDefColor); $lxAnz->configure(-background => $highLightBgColor); }; ($qb->{actAxis} eq "y") && do { $lxAnz->configure(-background => $labDefColor); $lzAnz->configure(-background => $labDefColor); $lyAnz->configure(-background => $highLightBgColor); }; ($qb->{actAxis} eq "z") && do { $lxAnz->configure(-background => $labDefColor); $lyAnz->configure(-background => $labDefColor); $lzAnz->configure(-background => $highLightBgColor); }; } } # updDashBoard # }}}2 #$top->bind('<A>' => # {{{2 # # uneingerastete Slice-Stellung, deren Möglichkeit ich au +s # # effekthascherischen Erwägungen beibehalten will, bringt + # # leider Mehraufwand mit sich. (eigentlich logisch) # # Nun der Versuch das in, auch noch nach Monaten verständ +- # liche Worte zu fassen. Also: # # # Definition: "gerastet" meint, daß die Kanten aller Cube +s # # eine Slices parallel zu den jeweils + korres- # # pondierenden Koordinatenachsen stehe +n. # # Zu Spielbegin sind alle Slices geras +tet. # # # # # Definition: "engaged" [(ein)gerastet] means that all cu +be- # # edges of a slice are parallel with the + parti- # # cular coordinate-axises. At the begin +ning of # # a game all slices are engaged. # # # # # - Doppelklick auf gerasteten Slice führt zu Achsen- # # wechsel. So solls auch sein. Ist der Slice nicht ge- # # rastet, so findet kein Achsenwechsel statt. Es können # # jetzt nur Slices gedreht werden, die senkrecht auf # # der gleichen Achse stehen. (Schaschlikspieß). # # # - Doubleclick on engaged slice leads to change of rota- # # tionaxis. That's the way it has to be. If the slice i +s # # not engaged there will be no change of axis. Only sli +ces # # then can be rotated which are vertical to the same ax +is. # # Think of a skewer. # # # - erst wenn alle Slices in der Flucht liegen UND gerast +et # # sind, kann wieder Achsenwechsel stattfinden. # # # - not until all slices lay in straight line AND are eng +a- # # ged change of axis can be done. # # # - sind alle Slices gefluchtet aber nicht gerastet, steh +en # # sie gemeinsam schief im KS. Um wieder in alle Richtun +gen # # beweglich zu sein, muß jetzt erst wieder Orthogonalit +ät # # zwischen Slices und KS hergestellt werden. # # # - if all slices are in straight line but not engaged th +ey # # have a common crooked position. To make them mavable +to # # all directions there has to be at first an orthogonal # # (relative) position between slices and coordinatesyst +em. # # # die folgende Subroutine soll ausgehend von einem repräs +en- # # tativen Slice alle drei gemeinsam zurück in einen geras +te- # # ten Zustand drehen. # # # the following subroutine ... # # sub { # print "<A>\n"; # # adjust (make orthogonal) slices # # relativ to coorSystem # # my $slice = $qb->{slice}{gripped}; # print "\$slice: $slice\n"; # $slice =~ /^(sl[xyz])/; # my $slPrfx = $1; # # my $steps = $qb->{rot}{$slice}; # my $dir = $steps / abs($steps); # $steps = abs($steps) % $rotSiSteps; # my $diff = $rotSiSteps - $steps; # if ($diff < $steps) { # $steps = $diff; # $dir = -$dir; # }; # # print "\$steps: $steps\n"; # print "\$dir: $dir\n"; # # $qb->{slice}{gripped} = ''; # # for (my $i = 1; $i <= $qbCubes; $i++) { # #for ("-10", " 0", " 10") { # my $slice = $slPrfx . $i; # print "\$slice: $slice\n"; # $qb->detSlViaNam($canvas, $slice); # $qb->oneSliceRotStep($steps, -$dir); # $qb->corr; # $qb->{rot}{$slice} = 0; # } # # }); # }}}2 $top->bind('<b>' => # {{{2 sub { print "<b>\n"; $qb->{shuffleBreak}++; }); # }}}2 $top->bind('<Control-c>' => \&lebWohl); $top->bind('<c>' => # {{{2 sub { print "Cubes ", $qb->check ? "bad" : "OK", "\n"; #print "\$qb->{constraint}\n"; #print Dumper $qb->{constraint}; foreach (qw(X Y Z)) { my $tr = "tri$_"; my $ax = lc($_) . "Axis"; print "\n$tr-eVec: \t("; print "$_\t" for @{$V->{$tr}->eVec}; print ")\t"; print "\n$ax-eVec: \t("; print "$_\t" for @{$V->{$ax}->eVec}; print ")\n"; print matob::vecsPhi( $V->{$tr}->eVec, $V->{$ax}->eVec ), "\n"; } }); # }}}2 $top->bind('<C>' => # {{{2 sub { my $initialColor = "gray"; $top->chooseColor(-title => "Choose a color", -ini +tialcolor => $initialColor); }); # }}}2 # <d> # {{{2 {my $x = 50; $top->bind('<d>' => sub { $x = ($x == 50) ? 0 : 50; $rfDeckl->configure(-width => $x); $tlfDeckl->configure(-width => $x); $blfDeckl->configure(-width => $x); }); }; # }}}2 $top->bind('<D>' => # {{{2 #$top->bind('<D>' => [\&autoRot, 2]); sub { print "_"x25, "slice-Dump-Anf", "_"x25,"\n"; print "slices: ", Dumper ($qb->{slice}), "\n"; print "="x25, "slice-Dump-End", "="x25,"\n"; }); # }}}2 $top->bind('<g>' => # {{{2 sub { print "\$qb->grippedS: ", $qb->{slice}{gripped}{name}, "\n"; }); # }}}2 $top->bind('<h>' => # {{{2 sub { print "\$highId: $highId\n"; }); # }}}2 $top->bind('<i>' => # {{{2 sub { $iColrFlag = $iColrFlag ? 0 : 1; plotAll(); }); # }}}2 $top->bind('<k>' => # {{{2 sub { $V->{plotCS} = $V->{plotCS} ? do {remCS; 0} : plotCS; }); # }}}2 $top->bind('<l>' => # {{{2 sub { print "\$mm: $mm\n"; $mm->rotate( $qb->{rS}, 0.0, 0.0) if ($qb->{actAxis} eq "x"); $mm->rotate( 0.0, $qb->{rS}, 0.0) if ($qb->{actAxis} eq "y"); $mm->rotate( 0.0, 0.0, $qb->{rS}) if ($qb->{actAxis} eq "z"); plotAll; }); # }}}2 $top->bind('<Control-l>' => # {{{2 sub { load(); }); # }}}2 $top->bind('<m>' => # {{{2 sub { #print Data::Dumper->Dump([$mm],['$mm']); print "\$mm:\n"; for (my $z=0; $z<4; $z++) { for (my $s=0; $s<4; $s++) { printf "%+0.2f ", $mm->[$z][$s]; } print "\n"; } my $im = invMat($mm); print "\$inv:\n"; for (my $z=0; $z<4; $z++) { for (my $s=0; $s<4; $s++) { printf "%+0.2f ", $im->[$z][$s]; } print "\n"; } my ($probe, $dummy) = ([]); $probe = matMult($dummy,$mm,$im); print "\$probe\n"; for (my $z=0; $z<4; $z++) { for (my $s=0; $s<4; $s++) { printf "%+0.2f ", $probe->[$z][$s]; } print "\n"; } }); # }}}2 $top->bind('<M>' => # {{{2 sub { { $mm->freeRot($V->{horiz}, -$qb->{rS}); } plotAll; }); # }}}2 $top->bind('<p>' => # {{{2 sub { #print "<p> tut nix\n"; print "\$actCube: $actCube\n"; }); # }}}2 $top->bind('<P>' => # {{{2 sub { { $mm->freeRot($V->{horiz}, $qb->{rS}); } plotAll; }); # }}}2 $top->bind('<Control-p>' => # {{{2 sub { print "CTRL-p\n"; foreach ($V->{xAxis}, $V->{yAxis}, $V->{zAxis}) { } }); # }}}2 $top->bind('<q>' => \&lebWohl); $top->bind('<r>' => # {{{2 sub { $mm->rotate(-$qb->{rS}, 0.0, 0.0) if ($qb->{actAxis} eq "x"); $mm->rotate( 0.0,-$qb->{rS}, 0.0) if ($qb->{actAxis} eq "y"); $mm->rotate( 0.0, 0.0,-$qb->{rS}) if ($qb->{actAxis} eq "z"); plotAll; }); # }}}2 $top->bind('<S>' => # {{{2 sub { keys %{$qb->{constraint}} && return; $qb->shuffle($V->{shuffleSteps}, $movLBox); }); # }}}2 $top->bind('<s>' => # {{{2 sub { $qb->{cube}[$actCube]->showAttr; }); # }}}2 $top->bind('<Control-s>' => # {{{2 sub { save(); }); # }}}2 $top->bind('<t>' => # {{{2 sub { print "matob::dotProd(\$xAxis, \$yAxis): ", matob::dotProd($V->{xAxis}, $V->{yAxis}), "\n" +; #$V->{horiz}->showAttr; }); # }}}2 $top->bind('<T>' => # {{{2 sub { print "$actCube\n"; #rp4rp3 $V->{triX} = new line3d($qb->{cube}[$actCube]{r2}{p4}, $qb->{cube}[$actCube]{ +r2}{p3}, 1, "white", "triX"); #rp4rp1 $V->{triY} = new line3d($qb->{cube}[$actCube]{r2}{p4}, $qb->{cube}[$actCube]{ +r2}{p1}, 1, "#42ff00", "triY"); #rp4gp4 $V->{triZ} = new line3d($qb->{cube}[$actCube]{r2}{p4}, $qb->{cube}[$actCube]{ +r4}{p1}, 1, "cyan", "triZ"); $V->{plotTri} = $V->{plotTri} ? do {remTri; 0} : plotT +ri; }); # }}}2 $top->bind('<u>' => # {{{2 sub { return unless my $rZug = $movLBox->get('end'); $qb->undoMove($rZug); $movLBox->delete('end'); $movLBox->see('end'); }); # }}}2 $top->bind('<v>' => # {{{2 sub { }); # }}}2 $top->bind('<V>' => # {{{2 sub { print Data::Dumper->Dump([%$V]); }); # }}}2 $top->bind('<X>' => # {{{2 sub { print Data::Dumper->Dump([%cL]); }); # }}}2 $top->bind('<w>' => # {{{2 sub { $qb->showAttr; }); # }}}2 $top->bind('<x>' => # {{{2 sub { $qb->{actAxis} = "x"; updDashBoard; }); # }}}2 $top->bind('<y>' => # {{{2 sub { $qb->{actAxis} = "y"; updDashBoard; }); # }}}2 $top->bind('<z>' => # {{{2 sub { $qb->{actAxis} = "z"; updDashBoard; }); # }}}2 $top->bind('<Button-2>' => # {{{2 sub { $V->{plotCS} = $V->{plotCS} ? do {remCS; 0} : plotCS; $V->{plotTri} = $V->{plotTri} ? do {remTri; 0} : plotT +ri; }); # }}}2 $top->bind('<MouseWheel>' => sub {print "MouseWheel\n"}); $rSentry->bind('<Enter>' => # {{{2 sub { $rSentry->focusNext; }); # }}}2 $leave->bind('<Button-1>' => \&lebWohl); $rfDeckl->bind('<Button-1>' => # {{{2 sub { #print "<Button-1 / \$rfDeckl>\n"; $rfDeckl->configure(-width => 0); }); # }}}2 $lvLab->bind('<Button-1>' => # {{{2 sub { #print "<Button-1 / \$lvLab>\n"; $rfDeckl->configure(-width => 50); }); # }}}2 $tlfDeckl->bind('<Button-1>' => # {{{2 sub { #print "<Button-1 / \$tlfDeckl>\n"; $tlfDeckl->configure(-width => 0); }); # }}}2 $blfDeckl->bind('<Button-1>' => # {{{2 sub { #print "<Button-1 / \$blfDeckl>\n"; $blfDeckl->configure(-width => 0); }); # }}}2 $hMovLBox->bind('<Button-1>' => # {{{2 sub { #print "<Button-1 / \$hMovLBox>\n"; $tlfDeckl->configure(-width => 50); }); # }}}2 $canvas->bind('line3d', '<Button-1>' => # {{{2 sub { print "'line3d', <Button-1>\n"; my $v = shift; my $id = $v->find(qw/withtag current/); my $name = ($v->gettags('current'))[0]; print "line3d $name\n"; $V->{$name}->showAttr; print "\neVec: ("; print "$_\t" for @{$V->{$name}->eVec}; print ")\n"; }); # }}}2 $canvas->bind('vec3d', '<Any-Enter>' => # {{{2 sub { print "'vec3d', <Any-Enter>\n"; my $v = shift; my $id = $v->find(qw/withtag current/); my $name = ($v->gettags('current'))[0]; my $ref; eval "\$ref = \$$name"; my ($x, $y, $z) = ($ref->{p2}{lx}, $ref->{p2}{ly}, $ref->{p2}{lz}) +; $vecAnz->configure( -background => $highLightBgColor, -text => $ref->{name} ); $sVxAnz->configure( -background => $highLightBgColor, -text => sprintf "%-0f", $x ); $sVyAnz->configure( -background => $highLightBgColor, -text => sprintf "%-0f", $y ); $sVzAnz->configure( -background => $highLightBgColor, -text => sprintf "%-0f", $z ); my $nrm = matob::vNorm($x, $y, $z); $sVnAnz->configure( -background => $highLightBgColor, -text => sprintf "%-0f", $nrm ); }); # }}}2 $canvas->bind('vec3d', '<Any-Leave>' => # {{{2 sub { $vecAnz->configure( -background => $labDefColor, ); $sVxAnz->configure( -background => $labDefColor, ); $sVyAnz->configure( -background => $labDefColor, ); $sVzAnz->configure( -background => $labDefColor, ); $sVnAnz->configure( -background => $labDefColor, ); }); # }}}2 $canvas->bind('cube', '<Button-1>' => # {{{2 sub { print "cube-<Button-1>\n"; my $e = $Tk::event; ($V->{xb1down}, $V->{yb1down}) = ($e->x, $e->y); $canvas->configure(-cursor => 'exchange'); $qb->{slice}{gripped} = $qb->{slice}{$sliceAnz->cget('-text')}; }); # }}}2 $canvas->bind('cube', '<Alt-Button-1>' => [ # {{{2 sub { my ($canv, $old_fill) = @_; #print "<Alt-Button-1>\n"; my $id = $canv->find(qw/withtag current/); #print "\$id: $id\n"; $canv->itemconfigure($id, -outline => "#ffff64", -width => 5 ); my $actRect = ($canv->gettags('current'))[1]; #print "\$actRect: $actRect\n"; print "\$old_fill: $$old_fill\n"; #my $initialColor = $$old_fill; my $newColor = $top->chooseColor( -title => "Choose a color" +, -initialcolor => $$old_fil +l); $newColor ||= $$old_fill; print "\$newColor: $newColor\n"; $qb->{cube}[$actCube]{$actRect}{iColr} = $newColor +; $canv->itemconfigure($id, -outline => "black", -width => 1 ); plotAll; }, \$V->{old_fill}]); # }}}2 $canvas->bind('cube', '<Double-Button-1>' => # {{{2 sub { print "<Double-Button-1>\n"; $qb->{slice}{marked}->changeColor(0); $canvas->configure(-cursor => 'exchange'); #$canvas->configure(-cursor => 'target'); my $canv = shift; { keys %{$qb->{constraint}} && last; $qb->{actAxis} eq "x" && do { $qb->{actAxi +s} = "y"; last; }; $qb->{actAxis} eq "y" && do { $qb->{actAxi +s} = "z"; last; }; $qb->{actAxis} eq "z" && do { $qb->{actA +xis} = "x"; last; }; } $qb->selSlice; plotAll; $sliceAnz->configure( -text => $qb->{slice}{marked}{name +}); $qb->{slice}{gripped} = $qb->{slice}{$sliceAnz->cget('-text' +)}; }); # }}}2 $canvas->bind('cube', '<Shift-Button-1>' => [ # {{{2 sub { my ($canv, $old_fill) = @_; print "<Shift-Button-1>\n"; my $id = $canv->find(qw/withtag current/); $canv->itemconfigure($id, -fill => undef); }, \$V->{old_fill}]); # }}}2 #$canvas->bind('cube', '<Any-Enter>' => [\&cscroll_enter, \$old_fill]) +; $canvas->bind('cube', '<Any-Enter>' => [ # {{{2 sub { #$qb->{slice}{gripped} && return; print "'cube', <Any-Enter>\n"; $V->{freezeCvac} || do { $V->{cvac}->{p2} = $qb->{cube}[$act +Cube]{centr}; plotAllVectors; }; $V->{PFLAG} == 0 && return; # OTHERWISE ENDLESS-LOO +P !!! my ($canv, $old_fill) = @_; my $id = $canv->find(qw/withtag current/); $id-- if ($canv->gettags('current'))[0] eq 'text'; $$old_fill = ($canv->itemconfigure($id, -fill))[4]; ($actCube = ($canv->gettags('current'))[0]) =~ s/c(\d+)/$1/; my $actRect = ($canv->gettags('current'))[1]; updDashBoard; $qb->selSlice; $sliceAnz->configure(-text => $qb->{slice}{marked}{nam +e}); $V->{PFLAG} = 0; # avoid renewed sub-run-through w +hich # will be caused (suspected) b +y poly- # gon-redrawings plotAll; # cube/rect-names in statusline # selected cubes-names should be red (deprecated due t +o # slice-highlighting ?) my $fg = $qb->{slice}{marked}{members}{$actCube} ? "red +" : $rgb +{DarkGreen}; $cubAnz->configure( -text => "c" . $actCube, -foreground => $fg); $rectAnz->configure( -text => $actRect); # update coordinate- and distance-display in dashboard my $dist = $mm->vNorm($qb->{cube}[$1]{centr}{wx}, $qb->{cube}[$1]{centr}{wy}, $qb->{cube}[$1]{centr}{wz} + $ +distance); $xKoor3d->configure(-text => sprintf "%0f", $qb->{cube}[$1 +]{centr}{wx}); $yKoor3d->configure(-text => sprintf "%0f", $qb->{cube}[$1 +]{centr}{wy}); $zKoor3d->configure(-text => sprintf "%0f", $qb->{cube}[$1 +]{centr}{wz}); $distLab->configure(-text => sprintf "%0f", $dist); $lxAnz->configure(-text => sprintf "%0f", $qb->{cube}[$1]{ce +ntr}{lx}); $lyAnz->configure(-text => sprintf "%0f", $qb->{cube}[$1]{ce +ntr}{ly}); $lzAnz->configure(-text => sprintf "%0f", $qb->{cube}[$1]{ce +ntr}{lz}); } , \$V->{old_fill}]); # }}}2 $canvas->bind('cube', '<Any-Leave>' => [ # {{{2 sub { my($canv, $old_fill) = @_; my $id = $canv->find(qw/withtag current/); $id-- if ($canv->gettags('current'))[0] eq 'text'; $canv->itemconfigure($id, -fill => $$old_fill); $qb->{slice}{marked}->changeColor(0); $V->{PFLAG} = 1; plotAll; } , \$V->{old_fill}]); # }}}2 $canvas->bind('cube', '<B1-Motion>' => # {{{2 sub { ($Z++ <= 1) ? return : do {$Z = 0}; foreach (keys %{$qb->{slice}{marked}{members}}) { $qb->{cube}[$_]{palette} = 0; } my $e = $Tk::event; my ($xnow, $ynow) = ($e->x, $e->y); my $dir = ($V->{xb1down} > $xnow) ? 1 : -1; $qb->{slice}{gripped}{rot} += $dir; $qb->{sMovFlag} = 1; foreach (keys %{$qb->{slice}{marked}{members}}) { $qb->{cube}[$_]->rotate($qb->{rS} * $dir, 0.0, + 0.0) if ($qb->{actAxis} eq +"x"); $qb->{cube}[$_]->rotate(0.0, $qb->{rS} * $dir, + 0.0) if ($qb->{actAxis} eq +"y"); $qb->{cube}[$_]->rotate(0.0, 0.0, $qb->{rS} * +$dir) if ($qb->{actAxis} eq +"z"); } plotAll; ($V->{xb1down}, $V->{yb1down}) = ($xnow, $ynow); }); # }}}2 $canvas->CanvasBind('<Motion>' => # {{{2 sub { $xKoor->configure(-text => $Tk::event->x); $yKoor->configure(-text => $Tk::event->y); }); # }}}2 $canvas->CanvasBind('<Control-Button-1>' => # {{{2 sub { print "<Control-Button-1>\n"; print "\$actCube: $actCube\n"; # hol mir das sliceObjekt zu diesem cube my $slice = $qb->sliceOfCube($actCube); $slice->changeColor; }); # }}}2 $canvas->CanvasBind('<Double-Button-3>' => # {{{2 sub { $V->{plotCS} = $V->{plotCS} ? do {remCS; 0} : plotCS; }); # }}}2 $canvas->CanvasBind('<Button-1>' => # {{{2 #$canvas->CanvasBind('<Button-3>' => sub { $qb->{slice}{gripped}{name} && return; $canvas->configure(-cursor => 'fleur'); plotAllVectors; my $e = $Tk::event; ($V->{xb3down}, $V->{yb3down}) = ($e->x, $e->y); }); # }}}2 $canvas->bind('cube', '<Button-3>' => [ # {{{2 sub { #$canvas->CanvasBind('<Button-3>' => [sub { my($w, $x, $y) = @_; print "\$hiddenM: $hiddenM\n"; $hiddenM->post($x, $y); }, Ev('X'), Ev('Y')]); #}}}2 $canvas->CanvasBind('<B1-Motion>' => # {{{2 #$canvas->CanvasBind('<B3-Motion>' => sub { $qb->{slice}{gripped}{name} && return; my $e = $Tk::event; my ($xnow, $ynow) = ($e->x, $e->y); my $xdir = ($V->{xb3down} - $xnow) / 10; my $ydir = ($V->{yb3down} - $ynow) / 10; $V->{horiz}->{p2}->creaHVWC([1, 0, 0]); $V->{vertik}->{p2}->creaHVWC([0, 1, 0]); $mm->freeRot($V->{horiz}, $qb->{rS} * -$ydir); $mm->freeRot($V->{vertik}, $qb->{rS} * -$xdir); plotAll; ($V->{xb3down}, $V->{yb3down}) = ($xnow, $ynow); }); # }}}2 $canvas->CanvasBind('<ButtonRelease-3>' => # {{{2 sub { $canvas->configure(-cursor => 'crosshair'); }); # }}}2 $canvas->CanvasBind('<ButtonRelease-1>' => sub # {{{2 { print "ButtonRelease-1\n"; print "\$qb->{slice}{gripped}{name} ", $qb->{slice}{gripped}{name},"\n"; $canvas->configure(-cursor => 'crosshair'); $V->{PFLAG} = 1; plotAll; my $slice = $qb->{slice}{gripped} || return; $qb->{slice}{gripped} = {}; $qb->{sMovFlag} && do { print "moved slice was : ", $slice->{name}, "\n"; my $rest = $slice->{rot} % $rotSiSteps; my $movs = int($slice->{rot} / $rotSiSteps); $rest ? do { #print "\$rest: $rest\n"; #print "incomplete move\n"; $qb->{constraint}{$slice->{name}} = $slice; } : do { #print "\$movs: $movs\n"; $qb->corr($slice); $movs && do { $zug = sprintf("%4d: %2s%-2d", $movLBox->index('end') + + 1, $slice->{name}, $movs); print "valid move: $zug\n"; $movLBox->insert('end', $zug); $movLBox->see('end'); $saveIt = 1; $slice->{rot} = 0; }; #print "delete ", $slice->{name}, "aus constra +intHash\n"; delete ${$qb->{constraint}}{$slice->{name}}; $qb->updSlices; }; }; $qb->{sMovFlag} = 0; print "Cubes ", $qb->check ? "bad" : "OK", "\n"; #print "members: ", Dumper $slice->{members}, "\n"; }); # }}}2 # END bindings }}}1 $mm->rotate(PI/-6, PI/6, 0.0); plotAll(); #$qb->detSlViaNam($canvas, "slx10"); #print ALL_EVENTS;