Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl: the Markov chain saw
 
PerlMonks  

comment on

( #3333=superdoc: print w/replies, xml ) Need Help??
#!/usr/bin/perl # # _ _____ # / / / / __ _| |__|___ / / / / / + # [][][]/ / _` | '_ \ |_ \ [][][]/ # [][][]/ | (_| | |_) |__) | [][][]/ # [][][]/ \__, |_.__/____/ [][][]/ # |_| # # $Id: qb3,v 0.68 2008/03/04 14:30:10 tos Exp tos $ # # # nomenclature # # qb : the whole rubics-cube-object # cube : one cubic element of qb # slice : cubes with a common x, y or z-axis-value # uses {{{1 use warnings; use strict; use Data::Dumper; use Tk; use Tk::DialogBox; use Tk qw/:eventtypes/; use Getopt::Std; use File::Basename; use constant PI => (atan2(1,1) * 4); #}}}1 # global vars {{{1 $|++; our ($VERSION, $opt_h, $opt_v, $opt_V) = ((qw($Revision: 0.68 $))[1], 0, 0, 0, 0); getopts('hl:vV') && &opts; our ( $canvas, $mm, $qb, $qbCubes, $actCube, $zug, $saveIt, $tl, $tlcs ); $qbCubes = 3; # 2 - 5 valid our ($screenWidth, $screenHeight, $distance) = (250, 250, 50); our $Z = 0; our $highId = 0; our $iColrFlag = 1; our $rotSiSteps = 8; our %rgb = ( "ora", "#ff9933", "pin", "#ff66cc", "red", "#dd0000", "gre", "#00d000", "blu", "#3399ff", "yel", "#ffff33", # "oral", "#ffce9e", # "pinl", "#ffbce8", # "redl", "#ec8282", # "grel", "#92cd92", # "blul", "#bcd9f8", # "yell", "#fffea1", "oral", "#ffefe0", "pinl", "#ffe8f7", "redl", "#f9d9d9", "grel", "#d9f7d9", "blul", "#e0efff", "yell", "#ffffe0", "orad", "#bf7326", "pind", "#bf4d99", "redd", "#a80000", "gred", "#008c00", "blud", "#2671bd", "yeld", "#bfbf26", "orag", "#70dc1e", "ping", "#70cf45", "redg", "#68b611", "greg", "#30ea11", "blug", "#3ddc51", "yelg", "#70f61e", "oray", "#fce00f", "piny", "#fcd13c", "redy", "#f2b300", "grey", "#b0f000", "bluy", "#c0e04c", "yely", "#fcff0f", "orar", "#59dbb7", "pinr", "#59c9ed", "redr", "#4da6a6", "grer", "#00eea6", "blur", "#11dbff", "yelr", "#59c9ed", "DarkRed", "#8b0000", "DarkGreen", "#006400", "DarkBlue", "#00008b", ); my $cRef = [ [$rgb{yel}, $rgb{yell}, $rgb{yeld}, $rgb{yelg}, $rgb{yely}, $rgb{yelr}], [$rgb{red}, $rgb{redl}, $rgb{redd}, $rgb{redg}, $rgb{redy}, $rgb{redr}], [$rgb{ora}, $rgb{oral}, $rgb{orad}, $rgb{orag}, $rgb{oray}, $rgb{orar}], [$rgb{gre}, $rgb{grel}, $rgb{gred}, $rgb{greg}, $rgb{grey}, $rgb{grer}], [$rgb{blu}, $rgb{blul}, $rgb{blud}, $rgb{blug}, $rgb{bluy}, $rgb{blur}], [$rgb{pin}, $rgb{pinl}, $rgb{pind}, $rgb{ping}, $rgb{piny}, $rgb{pinr}], ]; our %cD = our %cL = ( r1 => $cRef->[0], r2 => $cRef->[1], r3 => $cRef->[2], r4 => $cRef->[3], r5 => $cRef->[4], r6 => $cRef->[5], ); #}}}1 #--------------------------------------------------------------------- package matob; # {{{1 #--------------------------------------------------------------------- # 3D- and matrix-computing # - - - - - - - - - - - - - - - - - - - + use constant EPSILON => 1e-09; sub new { # {{{2 my ($pkg, $t) = @_; # $t = 0, nullmatrix # $t = 1, identity-matrix bless [ [$t, 0, 0, 0], [0, $t, 0, 0], [0, 0, $t, 0], [0, 0, 0, $t] ], $pkg; }; # constructor }}}2 sub freeRot { # {{{2 # rotation around arbitrary axis which intersects the origin. # must have a norm of 1 to avoid changes of ojectsize shift; my ($ra, $phi) = @_; die if ref($ra) ne "vec3d"; my $x = $ra->{p2}{lx}; my $y = $ra->{p2}{ly}; my $z = $ra->{p2}{lz}; my $sphi = sin($phi); my $cphi = cos($phi); my $emcphi = 1 - cos($phi); my ($xmat, $mat1) = (new matob, new matob); $xmat->[0][0] = $x * $x * $emcphi + $cphi; $xmat->[0][1] = $x * $y * $emcphi - $z * $sphi; $xmat->[0][2] = $x * $z * $emcphi + $y * $sphi; $xmat->[0][3] = 0; $xmat->[1][0] = $x * $y * $emcphi + $z * $sphi; $xmat->[1][1] = $y * $y * $emcphi + $cphi; $xmat->[1][2] = $y * $z * $emcphi - $x * $sphi; $xmat->[1][3] = 0; $xmat->[2][0] = $x * $z * $emcphi - $y * $sphi; $xmat->[2][1] = $y * $z * $emcphi + $x * $sphi; $xmat->[2][2] = $z * $z * $emcphi + $cphi; $xmat->[2][3] = 0; $xmat->[3][0] = 0; $xmat->[3][1] = 0; $xmat->[3][2] = 0; $xmat->[3][3] = 1; matMult($mat1,$xmat,$mm); matCopy($mm,$mat1); } # freeRot }}}2 sub invMat { # {{{2 my $m = shift; # Inverses of 3x3-Matrices can be determined with # determinants (hihi) and because the neutral element # (line 3, row 3) at this point has no influence on the # resulting determinant, we can simply reduce our matrix # to 3x3 and then solve it by the rule of Sarrus my $det = $m->[0][0] * $m->[1][1] * $m->[2][2] + $m->[0][1] * $m->[1][2] * $m->[2][0] + $m->[0][2] * $m->[1][0] * $m->[2][1] - $m->[2][0] * $m->[1][1] * $m->[0][2] - $m->[2][1] * $m->[1][2] * $m->[0][0] - $m->[2][2] * $m->[1][0] * $m->[0][1]; my $x = [ [ $m->[1][1] * $m->[2][2] - $m->[1][2] * $m->[2][1], $m->[0][2] * $m->[2][1] - $m->[0][1] * $m->[2][2], $m->[0][1] * $m->[1][2] - $m->[0][2] * $m->[1][1], ], [ $m->[1][2] * $m->[2][0] - $m->[1][0] * $m->[2][2], $m->[0][0] * $m->[2][2] - $m->[0][2] * $m->[2][0], $m->[0][2] * $m->[1][0] - $m->[0][0] * $m->[1][2], ], [ $m->[1][0] * $m->[2][1] - $m->[1][1] * $m->[2][0], $m->[0][1] * $m->[2][0] - $m->[0][0] * $m->[2][1], $m->[0][0] * $m->[1][1] - $m->[0][1] * $m->[1][0], ], ]; my $inv = new(1); for (my $z = 0; $z < 3; $z++) { for (my $s = 0; $s < 3; $s++) { $inv->[$z][$s] = $det * $x->[$z][$s]; } } $inv; } # matInv }}}2 sub matCopy { # {{{2 # copy matrices my ($dest, $source) = @_; for (my $i=0; $i<4; $i++) { for (my $j=0; $j<4; $j++) { $dest->[$i][$j] = $source->[$i][$j]; } } } # matCopy }}}2 sub matMult { # {{{2 # multiply matrices my ($result, $mat1, $mat2) = @_; for (my $i=0; $i<4; $i++) { for (my $j=0; $j<4; $j++) { for (my $k=0; $k<4; $k++) { $result->[$i][$j] += $mat1->[$i][$k] * $mat2->[$k][$j +]; } } } $result; # sollte auch fuer $mat1 verwendet werden ... } # matMult }}}2 sub rotate { # {{{2 # rotation around local x, y, and z-axis shift; my ($ax, $ay, $az) = @_; # x-rotationmatrix unless ($ax == 0) { my ($xmat, $mat1) = (new matob, new matob); $xmat->[0][0] = 1; $xmat->[0][1] = 0; $xmat->[0][2] = 0; $xmat->[0][3] = 0; $xmat->[1][0] = 0; $xmat->[1][1] = cos($ax); $xmat->[1][2] = sin($ax); $xmat->[1][3] = 0; $xmat->[2][0] = 0; $xmat->[2][1] = -1 * sin($ax); $xmat->[2][2] = cos($ax); $xmat->[2][3] = 0; $xmat->[3][0] = 0; $xmat->[3][1] = 0; $xmat->[3][2] = 0; $xmat->[3][3] = 1; matMult($mat1,$xmat,$mm); matCopy($mm,$mat1); } # y-rotationmatrix unless ($ay == 0) { my ($ymat, $mat1) = (new matob, new matob); $ymat->[0][0] = cos($ay); $ymat->[0][1] = 0; $ymat->[0][2] = -1 * sin($ay); $ymat->[0][3] = 0; $ymat->[1][0] = 0; $ymat->[1][1] = 1; $ymat->[1][2] = 0; $ymat->[1][3] = 0; $ymat->[2][0] = sin($ay); $ymat->[2][1] = 0; $ymat->[2][2] = cos($ay); $ymat->[2][3] = 0; $ymat->[3][0] = 0; $ymat->[3][1] = 0; $ymat->[3][2] = 0; $ymat->[3][3] = 1; matMult($mat1,$ymat,$mm); matCopy($mm,$mat1); } # z-rotationmatrix unless ($az == 0) { my ($zmat, $mat1) = (new matob, new matob); $zmat->[0][0] = cos($az); $zmat->[0][1] = sin($az); $zmat->[0][2] = 0; $zmat->[0][3] = 0; $zmat->[1][0] = -1 * sin($az); $zmat->[1][1] = cos($az); $zmat->[1][2] = 0; $zmat->[1][3] = 0; $zmat->[2][0] = 0; $zmat->[2][1] = 0; $zmat->[2][2] = 1; $zmat->[2][3] = 0; $zmat->[3][0] = 0; $zmat->[3][1] = 0; $zmat->[3][2] = 0; $zmat->[3][3] = 1; matMult($mat1,$zmat,$mm); matCopy($mm,$mat1); } }; # rotate }}}2 sub vecsPhi { # {{{2 # expects R3-unit vectors as references on 3-element-lists my ($v, $w) = @_; #dotProd($v, $w) / (vNorm(@$v) * vNorm(@$w)); dotProd($v, $w); } # vecsPhi }}}2 sub vNorm { # {{{2 my ($x, $y, $z) = @_; # square root of scalar product sqrt ($x * $x + $y * $y + $z * $z); } # vNorm }}}2 sub dotProd { # {{{2 # expects R3-unit vectors as references on 3-element-lists my ($v, $w) = @_; $v->[0] * $w->[0] + $v->[1] * $w->[1] + $v->[2] * $w->[2]; }; #dotProd }}}2 sub notNull { #{{{2 # retuns 0 if value "near" enough to 0 my $n = shift; abs($n) > EPSILON ? $n : 0; }; #notNull }}}2 # package matob; }}}1 #--------------------------------------------------------------------- package point3d; # {{{1 #--------------------------------------------------------------------- use Data::Dumper; # lx, ly, lz : # local coordinates # wx, wy, wz : # worldcoordinatesystem is 'leftsystem' # sx, sy : # screenkoordinates sub new { # {{{2 my ($pkg, $X, $Y, $Z) = @_; bless { lx => $X, ly => $Y, lz => $Z, }, $pkg; }; # constructor }}}2 sub creaHVWC { # {{{2 # find out the worldcoordinates for horizontal and vertical # axis to get "artificial horizon" my ($p, $eAxis) = @_; return 0 if ref($p) ne "point3d"; # multiplication with inverse matrix to reverse rotation for # horizontal and vertical vector my $i = $mm->invMat; my ($lx, $ly, $lz) = @$eAxis; $p->{lx} = $lx * $i->[0][0] + $ly * $i->[1][0] + $lz * $i->[2][0] + $i->[3][0]; $p->{ly} = $lx * $i->[0][1] + $ly * $i->[1][1] + $lz * $i->[2][1] + $i->[3][1]; $p->{lz} = $lx * $i->[0][2] + $ly * $i->[1][2] + $lz * $i->[2][2] + $i->[3][2]; # $corr is necessary to keep the "Einheits"-lenght # on the rotation-axis-vector. Without this correction # the norm of the rotation-axis-vector will shrink or grow # due to inexact(floatingpoint) computings. In this case # the cube will suddenly shrink or grow after a couple # of rotations are made. Though the shrinking is funny # to look at, it's not desired. my $corr = sqrt(1 / ( $p->{lx} * $p->{lx} + $p->{ly} * $p->{ly} + $p->{lz} * $p->{lz} ) ); # uncomment the following three lines if you want to see # the shrink-/grow-effekt. Therefore you have to do several # Button3-Motions of the whole cube. $p->{lx} *= $corr; $p->{ly} *= $corr; $p->{lz} *= $corr; }; # creaHVWC }}}2 sub creaWC { # {{{2 my $p = shift; return 0 if ref($p) ne "point3d"; $p->{wx} = $p->{lx} * $mm->[0][0] + $p->{ly} * $mm->[1][0] + $p->{lz} * $mm->[2][0] + $mm->[3][0]; $p->{wy} = $p->{lx} * $mm->[0][1] + $p->{ly} * $mm->[1][1] + $p->{lz} * $mm->[2][1] + $mm->[3][1]; $p->{wz} = $p->{lx} * $mm->[0][2] + $p->{ly} * $mm->[1][2] + $p->{lz} * $mm->[2][2] + $mm->[3][2]; }; # creaWC }}}2 sub project3dTo2d { # {{{2 my $p = shift; return 0 if ref($p) ne "point3d"; my $xoffset = $screenWidth/2; my $yoffset = $screenHeight/2; $p->{sx} = 200 * $p->{wx} / ($p->{wz} + $distance) + $xoffset; $p->{sy} = -200 * $p->{wy} / ($p->{wz} + $distance) + $yoffset +; }; # project3dTo2d }}}2 sub rotate { # {{{2 my ($p, $ax, $ay, $az) = @_; my ($lx, $ly, $lz); unless ($ax == 0) { # x-axis-rotation ($ly, $lz) = ($p->{ly}, $p->{lz}); $p->{ly} = $ly * cos($ax) - $lz * sin($ax); $p->{lz} = $ly * sin($ax) + $lz * cos($ax); } unless ($ay == 0) { # y-axis-rotation ($lx, $lz) = ($p->{lx}, $p->{lz}); $p->{lz} = $lz * cos($ay) - $lx * sin($ay); $p->{lx} = $lz * sin($ay) + $lx * cos($ay); } unless ($az == 0) { # z-axis-rotation ($lx, $ly) = ($p->{lx}, $p->{ly}); $p->{lx} = $lx * cos($az) - $ly * sin($az); $p->{ly} = $lx * sin($az) + $ly * cos($az); } } # rotate }}}2 sub showAttr { # {{{2 print Dumper(shift); }; #showAttr }}}2 # package point3d; }}}1 #--------------------------------------------------------------------- package line3d; # {{{1 #--------------------------------------------------------------------- use Data::Dumper; sub new { # {{{2 my ($pkg, $P1, $P2, $visible, $color, $name) = @_; return 0 if ( ref($P1) ne "point3d" or ref($P2) ne "point3d" ); bless { p1 => $P1, p2 => $P2, visible => $visible, color => $color, name => $name, }, $pkg; }; # constructor }}}2 sub clear { # {{{2 my $l = shift; #return 0 if ref($l) ne "line3d"; $canvas->delete($l->{name}); } # clear }}}2 sub creaWC { # {{{2 my $l = shift; #return 0 if ref($l) ne "line3d"; $l->{$_}->creaWC for qw(p1 p2); }; # creaWC }}}2 sub eVec { # {{{2 my $l = shift; return undef unless isLine3d($l); my ($norm, $eVec) = (norm($l), []); @$eVec = map { matob::notNull( ($l->{p2}{$_} - $l +->{p1}{$_}) / $norm ) } qw(lx ly lz); $eVec; }; # eVec }}}2 sub isLine3d { # {{{2 my $l = shift; ref($l) ne "line3d" && do { print "$l not type \"line3 +d\"\n"; return 0; }; 1; }; #isLine3d }}}2 sub norm { # {{{2 my $l = shift; return undef unless isLine3d($l); matob::vNorm( $l->{p2}{lx} - $l->{p1}{lx}, $l->{p2}{ly} - $l->{p1}{ly}, $l->{p2}{lz} - $l->{p1}{lz} ); } # norm }}}2 sub plot { # {{{2 my $l = shift; #return 0 if ref($l) ne "line3d"; my $tag = $l->{name}; return unless $l->{visible}; $canvas->delete($tag); $l->creaWC; $l->project3dTo2d; if ($l->{visible}) { $canvas->createLine ( $l->{p1}{sx}, $l->{p1}{sy}, $l->{p2}{sx}, $l->{p2}{sy}, -fill => $l->{color}, -tags => [$tag, "line3d"], -arrow => "last", -activefill => "yellow", ); } } # plot }}}2 sub project3dTo2d { # {{{2 my $l = shift; #return 0 if ref($l) ne "line3d"; $l->{$_}->project3dTo2d for qw(p1 p2); }; # project3dTo2d }}}2 sub showAttr { # {{{2 print Dumper(shift); }; #showAttr }}}2 # package line3d; }}}1 #--------------------------------------------------------------------- package vec3d; # {{{1 #--------------------------------------------------------------------- # dient v.a. der Selbstverdeutlichung der perl'schen Veerbungs- # lehre. 'vec3ds' sind 'line3ds' deren p1 der Ursprung ist. # i.Ü. muß eine Erbenklasse noch nicht einmal einen eigenen Kon- # struktor haben. # die Typprüfung in line3d müßte eigentlich um 'vec3d' erweitert # werden. ABER, ist das dann noch oo-sauber ? use Data::Dumper; our @ISA = qw(line3d); sub new { # {{{2 my ($pkg, $p, $visible, $color, $name) = @_; $pkg->SUPER::new ( new point3d(0, 0, 0), $p, $visible, $color, $name ); }; # constructor }}}2 sub eVec { # {{{2 my $v = shift; return undef unless isVec3d($v); my ($norm, $eVec) = (norm($v), []); @$eVec = map { matob::notNull($v->{p2}{$_} / $norm) } qw(lx ly lz); $eVec; }; # eVec }}}2 sub isVec3d { # {{{2 my $v = shift; ref($v) ne "vec3d" && do { print "$v not type \"vec3d +\"\n"; return 0; }; 1; }; #isVec3d }}}2 sub norm { # {{{2 my $v = shift; return undef unless isVec3d($v); matob::vNorm($v->{p2}{lx}, $v->{p2}{ly}, $v->{p2}{lz}); } # norm }}}2 sub plot { # {{{2 my $l = shift; #return 0 if ref($l) ne "vec3d"; my $tag = $l->{name}; return unless $l->{visible}; $canvas->delete($tag); $l->creaWC; $l->project3dTo2d; if ($l->{visible}) { $canvas->createLine ( $l->{p1}{sx}, $l->{p1}{sy}, $l->{p2}{sx}, $l->{p2}{sy}, -fill => $l->{color}, -tags => [$tag, "vec3d"], -arrow => "last", -activefill => "yellow", ); } } # plot }}}2 sub rotate { # {{{2 my ($v, $ax, $ay, $az) = @_; $v->{p2}->rotate($ax, $ay, $az); }; # rotate }}}2 sub showAttr { # {{{2 print Dumper(shift); }; #showAttr }}}2 # package vec3d; }}}1 #--------------------------------------------------------------------- package rect3d; # {{{1 #--------------------------------------------------------------------- use Data::Dumper; sub new { # {{{2 my ($pkg, $P1, $P2, $P3, $P4, $visible, $color, $name) = @_; return 0 if ( ref($P1) ne "point3d" or ref($P2) ne "point3d" or ref($P3) ne "point3d" or ref($P4) ne "point3d" ); bless { p1 => $P1, p2 => $P2, p3 => $P3, p4 => $P4, visible => $visible, # for BackfaceCulling color => $color, # side-color, @-refer +enz # palette-based iColr => "gray", # individual Color ! name => $name, }, $pkg; }; # constructor sub creaWC { # /** # * Diese Methode multipliziert die 3DVektoren der LOKALEN- # * Koordinaten des Objektes mit der Transformationsmatrix, # * die die Daten für Rotation,Verschiebung,Skalierung # * enthält, und speichert die Berechnungen als die WELT- # * Koordinaten des Objektes ab. # * # * @param r Für dieses Rechteck wird die Transformation # * durchgeführt # */ my $r = shift; return 0 if ref($r) ne "rect3d"; foreach my $p qw(p1 p2 p3 p4) { $r->{$p}->creaWC; } }; # creaWC }}}2 sub backfaceCulling { # {{{2 # /** # * Berechnet, in welche Richtung das Polygon zeigt. # * Die Formel ist die letzte Zeile des Vektorproduktes # * und gibt die z-Koordinate des Normalenvektors aus # * den ersten drei Punkten des Polygons an (BILDSCHIRM- # * Koordinaten). Ist z positiv, so zeigt die Fläche # * mindestens 90 Grad vom Betrachter weg. # */ my $r = shift; return 0 if ref($r) ne "rect3d"; my $z = ($r->{p2}{sx} - $r->{p1}{sx}) * ($r->{p3}{sy} - $r->{p1}{sy}) - ($r->{p2}{sy} - $r->{p1}{sy}) * ($r->{p3}{sx} - $r->{p1}{sx}); $r->{visible} = ($z <= 0) ? 0 : 1; }; # backfaceCulling }}}2 sub plot { # {{{2 my $r = shift; return 0 if ref($r) ne "rect3d"; my ($cTag, $palType, $side) = @_; $r->project3dTo2d; $r->backfaceCulling; my $color; if ($r->{visible}) { $color = $iColrFlag ? $cL{$side}[$palType] : $r->{iColr}; unless ($r->{id}) { # object doesn't yet exist $r->{id} = $canvas->createPolygon ( $r->{p1}{sx}, $r->{p1}{sy}, $r->{p2}{sx}, $r->{p2}{sy}, $r->{p3}{sx}, $r->{p3}{sy}, $r->{p4}{sx}, $r->{p4}{sy}, -fill => $color, -tags => [$cTag, $_, "cube"], -outline => "black", -activewidth => 5, -activeoutline => "#c2ff51", #-stipple => $main::stipple, ); $highId = $r->{id}; } else { my $x = $r->{id}; $canvas->raise($x); $canvas->coords( $r->{id}, $r->{p1}{sx}, $r->{p1}{sy}, $r->{p2}{sx}, $r->{p2}{sy}, $r->{p3}{sx}, $r->{p3}{sy}, $r->{p4}{sx}, $r->{p4}{sy}, ); $canvas->itemconfigure ($r->{id}, -fill => $color, ); } } else { # keep object with size 0 at position 0 $canvas->coords($r->{id}, 0, 0, 0, 0, 0, 0, 0, 0); } }; # plot }}}2 sub project3dTo2d { # {{{2 # /** # * Projiziert die 3DVektoren der WELT-Koordinaten des # * Objektes auf 2DVektoren, die die BILDSCHIRM-Koordinaten # * des Objektes angeben. # * # * @param r Für dieses Rechteck wird die Projektion # * durchgeführt # */ my $r = shift; return 0 if ref($r) ne "rect3d"; $r->{$_}->project3dTo2d for qw(p1 p2 p3 p4); }; # project3dTo2d }}}2 sub rotate { # {{{2 my ($r, $ax, $ay, $az) = @_; return 0 if ref($r) ne "rect3d"; $r->{$_}->rotate($ax, $ay, $az) for qw(p1 p2 p3 p4); } # rotate }}}2 sub showAttr { # {{{2 print Dumper(shift); }; # showAttr }}}2 # package rect3d; }}}1 #--------------------------------------------------------------------- package cube3d; # {{{1 #--------------------------------------------------------------------- use Data::Dumper; our $hsl; sub new { # {{{2 my $pkg = shift; my ( $origX, $origY, $origZ, $sideLen, $name, $visible, $pal) = @_; $hsl = $sideLen / 2; my ($p1, $p2, $p3, $p4, $p5, $p6, $p7, $p8, $centr) = ( new point3d($origX - $hsl, $origY - $hsl, $origZ + $hs +l), new point3d($origX + $hsl, $origY - $hsl, $origZ + $hs +l), new point3d($origX + $hsl, $origY + $hsl, $origZ + $hs +l), new point3d($origX - $hsl, $origY + $hsl, $origZ + $hs +l), new point3d($origX - $hsl, $origY + $hsl, $origZ - $hs +l), new point3d($origX + $hsl, $origY + $hsl, $origZ - $hs +l), new point3d($origX + $hsl, $origY - $hsl, $origZ - $hs +l), new point3d($origX - $hsl, $origY - $hsl, $origZ - $hs +l), new point3d($origX , $origY , $origZ + ), ); # back my $r1 = new rect3d( $p1, $p2, $p3, $p4, 1, $cL{r1}, "yel"); # front my $r2 = new rect3d( $p5, $p6, $p7, $p8, 1, $cL{r2}, "red"); # top my $r3 = new rect3d( $p4, $p3, $p6, $p5, 1, $cL{r3}, "ora"); # bottom my $r4 = new rect3d( $p1, $p8, $p7, $p2, 1, $cL{r4}, "gre"); # right my $r5 = new rect3d( $p2, $p7, $p6, $p3, 1, $cL{r5}, "blu"); # left my $r6 = new rect3d( $p8, $p1, $p4, $p5, 1, $cL{r6}, "pin"); my $obj = bless { r1 => $r1, r2 => $r2, r3 => $r3, r4 => $r4, r5 => $r5, r6 => $r6, name => $name, centr => $centr, visible => $visible, palette => $pal, }, $pkg; $obj->{centr}->creaWC; # Cube-Center $obj; }; # constructor }}}2 sub check { # {{{2 my $c = shift; my $stat = 0; unless ($c->{centr}{lx} == int($c->{centr}{lx})) { print $c->{name}, " lx: ", $c->{centr}{lx}," "; $stat++; }; unless ($c->{centr}{ly} == int($c->{centr}{ly})) { print $c->{name}, " ly: ", $c->{centr}{ly}," "; $stat++; }; unless ($c->{centr}{lz} == int($c->{centr}{lz})) { print $c->{name}, " lz: ", $c->{centr}{lz}," "; $stat++; }; $stat; }; #showAttr }}}2 sub creaWC { # {{{2 my $c = shift; return 0 if ref($c) ne "cube3d"; $c->{centr}->creaWC; $c->{$_}->creaWC for (qw|r1 r2 r3 r4 r5 r6|); }; # creaWC }}}2 sub plot { # {{{2 my $c = shift; return 0 if ref($c) ne "cube3d"; my $palType = $c->{palette}; my $cTag = "c" . $c->{name}; return unless $c->{visible}; foreach (qw|r1 r2 r3 r4 r5 r6|) { $c->{$_}->plot($cTag, $palType, $_); } } # plot }}}2 sub rotate { # {{{2 my ($c, $ax, $ay, $az) = @_; return 0 if ref($c) ne "cube3d"; $c->{$_}->rotate($ax, $ay, $az) for qw(r1 r2 r3 r4 r5 r6); # 040516.1030 : # durch Visualisierung ausgewählter Punktvektoren, finde ich # heraus, daß der centr-Punkt erst nach drei Umläufen eines # Einzelcubes (z.b. c20) wieder den korrekten Wert annimmt. # warum nun der Faktor 3, für ein sauberes 'Mitlaufen' des # centr-Punkts eines Cubes sorgt, bleibt mir bislang schleier- # haft. $c->{centr}->rotate($ax * 3, $ay * 3, $az * 3); } # rotate }}}2 sub showAttr { # {{{2 my $c = shift; print Dumper($c); }; #showAttr }}}2 sub visible { # {{{2 my ($c, $visible) = @_; return 0 if ref($c) ne "cube3d"; foreach my $r qw(r1 r2 r3 r4 r5 r6) { $c->{$r}{visible} = $visible; } 1; }; # visible }}}2 # package cube3d; }}}1 #--------------------------------------------------------------------- package slice; # {{{1 #--------------------------------------------------------------------- # use Data::Dumper; use constant EPSILON => 1e-09; my $lastActAxis; sub new { # {{{2 my ($pkg, $name) = @_; $name =~ /([xyz])(\d+)/; bless { name => $name, axis => $1, val => undef, propos => 0, #gripped => 0, members => {}, }, $pkg; }; # constructor }}}2 sub examine { # {{{2 my ($val, $axis) = @_; my %sm; #print "\$val: $val\n"; #print "\$axis: $axis\n"; foreach (@{$qb->{cube}}) { ($axis eq "x") && do { abs($_->{centr}{lx} - $val) < EPSI +LON && do {$sm{$_->{name}} = 1}; next; }; ($axis eq "y") && do { abs($_->{centr}{ly} - $val) < EPSI +LON && do {$sm{$_->{name}} = 1}; next; }; ($axis eq "z") && do { abs($_->{centr}{lz} - $val) < EPSI +LON && do {$sm{$_->{name}} = 1}; next; }; print "*** HIER DARF ICH NICHT HIN ***\n"; } keys %sm != $qbCubes * $qbCubes && do { print Dumper \%sm; main::show_msg("error", "slice-integrity corru +pted"); }; \%sm; }; # examine }}}2 sub changeColor { # {{{2 my ($s, $num) = @_; foreach (keys %{$s->{members}}) { $qb->{cube}[$_]->{palette} = $num; } } # changeColor }}}2 sub members { # {{{2 my $s = shift; $s->{members} = examine($s->{val}, $s->{axis}); }; # members }}}2 sub propose { # {{{2 }; # propose }}}2 sub showAttr { # {{{2 print Dumper(shift); }; #showAttr }}}2 # package slice; }}}1 #--------------------------------------------------------------------- package qb; # {{{1 #--------------------------------------------------------------------- use Data::Dumper; use Tk; use Tk qw/:eventtypes/; use constant PI => (atan2(1,1) * 4); use constant EPSILON => 1e-09; sub new { # qb-object {{{2 my ($pkg, $k, $gap) = @_; my @c; # bislang wurde die jeweilige Achsenpostion eines Slices (aus Bequem- # lichkeitsgründen) direkt im Slicenamen wiedergespiegelt, z.b. # 'sly-10'. Da nun verschieden große qbs möglich sind, muß die Slice- # benamsung generalisiert werden. Slicenamen werden künfig, beginnend # beim "negativsten" aufsteigend durchnumeriert. Bsp.: 3er_qb # 'sly-10' wird 'sly1', 'sly 0' wird 'sly2' usw. # 3er-Cube # perl -we '$sl=10;foreach $z (-$sl, 0, $sl) {foreach $y (-$sl, 0, $sl +) {foreach $x (-$sl, 0, $sl) {printf "%3d %3d %3d %3d \n", $i++, $x, +$y, $z};print "\n"};print "\n"}' my (@seq, $sl, $spalt, $slap2n, $n2slap); CASE: { # welches Schweinderl hätten's denn gern ? {{{3 ($k == 2) && do { ($sl, $spalt) = (12, $gap && 1.2); my $slh = $sl/2; @seq = ([$slh, -$slh], [-$slh, $slh]); # SliceAxisPosition to ordNum $slap2n = {-$slh,1,$slh,2}; # ordNum to slap. First Value is dummy. $n2slap = [2, -$slh, $slh]; }; ($k == 3) && do { ($sl, $spalt) = (10, $gap && 1); @seq = ([$sl, 0, -$sl], [-$sl, 0, $sl]); # SliceAxisPosition to ordNum $slap2n = {-$sl,1,0,2,$sl,3}; # ordNum to slap. First Value is dummy. $n2slap = [3, -$sl, 0, $sl]; }; ($k == 4) && do { ($sl, $spalt) = (8, $gap && .8); my $slh = $sl/2; @seq = ( [$slh * 3, $slh, -$slh, -$slh * 3] +, [-$slh * 3, -$slh, $slh, $slh * 3] +); # SliceAxisPosition to ordNum $slap2n = {-$slh * 3, 1, -$slh, 2, $slh, 3, $slh * 3, 4}; # ordNum to slap. First Value is dummy. $n2slap = [4, -$slh * 3, -$slh, $slh, $slh * 3 +]; }; ($k == 5) && do { ($sl, $spalt) = (6, $gap && .6); @seq = ( [$sl * 2, $sl, 0, -$sl, -$sl * 2], + [-$sl * 2, -$sl, 0, $sl, $sl * 2]) +; # SliceAxisPosition to ordNum $slap2n = {-$sl * 2, 1, -$sl ,2, 0, 3, $sl, 4, $sl * 2, 5}; # ordNum to slap. First Value is dummy. $n2slap = [5, -$sl * 2, -$sl, 0, $sl, $sl * 2] +; }; } # }}}3 my ($i, $sp) = (0, $sl - $spalt); foreach my $z (@{$seq[0]}) { foreach my $y (@{$seq[0]}) { foreach my $x (@{$seq[1]}) { $c[$i] = new cube3d( $x, $y, $z, $sp, sprintf ("%02d", $i), +1, 0); $i++; }; }; }; my %s; foreach my $j (qw(x y z)) { for (my $i = 1; $i <= $k; $i++) { $s{"$j$i"} = new slice("$j$i"); }; }; my $steps = $rotSiSteps * 6; bless { cube => \@c, # single-cubes slice => \%s, # slices sideLen => $sl, s2n => $slap2n, # slicenames n2s => $n2slap, sMovFlag => 0, actAxis => '', rS => PI / $steps, }, $pkg; }; # constructor }}}2 sub autoRot { # {{{2 my ($qb, $dSteps) = @_; my $steps = abs($dSteps); my $dir = $dSteps / $steps; while ($steps-- > 0) { my $tick = 0; while ($tick++ < $rotSiSteps) { $qb->oneSliceRotStep(1, $dir); #DoOneEvent(DONT_WAIT); DoOneEvent(); } } $qb->updSlices(); $qb->{slice}{marked}->changeColor(0); $qb->corr; $qb->plotAllCubes; }; # autoRot }}}2 sub check { # {{{2 my $c = shift; my $stat = 0; foreach (@{$qb->{cube}}) { $stat += $_->check; } $stat; }; #check }}}2 sub corr { # {{{2 # if the mousepointer leaves the gripped Slice while rotation # and enters another slice, this one will be the 'selCubes'- # slice. The next statement makes sure that the actually rotat +ed # slice will be corrected. # Surely there is a cheaper solution concerning the performanc +e- # aspect but for now this one will be good enough. #$qb->detSlViaNam($canvas, $qb->{slice}{gripped}) if $qb->{sli +ce}{gripped}; # correct inaccurancies in local-x/y/z-values my ($qb, $slice) = @_; $slice ||= $qb->{slice}{marked}; print "correcting inaccuracies in slice ", $slice->{name}, "\n"; my $x; foreach (keys %{$slice->{members}}) { print "$_ vor "; print "(lx, ly, lz): (", $qb->{cube}[$_]{centr}{lx},", ", $qb->{cube}[$_]{centr}{ly},", ", $qb->{cube}[$_]{centr}{lz},")\n"; $x = sprintf "%.0f",$qb->{cube}[$_]{centr}{lx}; $qb->{cube}[$_]{centr}{lx} = ($x =~ /^-0$/) ? "0" : $x; $x = sprintf "%.0f",$qb->{cube}[$_]{centr}{ly}; $qb->{cube}[$_]{centr}{ly} = ($x =~ /^-0$/) ? "0" : $x; $x = sprintf "%.0f",$qb->{cube}[$_]{centr}{lz}; $qb->{cube}[$_]{centr}{lz} = ($x =~ /^-0$/) ? "0" : $x; print "$_ nach "; print "(lx, ly, lz): (", $qb->{cube}[$_]{centr}{lx},", ", $qb->{cube}[$_]{centr}{ly},", ", $qb->{cube}[$_]{centr}{lz},")\n\n"; } }; # corr }}}2 sub selSlice { # {{{2 my ($qb, $slice) = @_; $qb->{slice}{marked} = $slice ? (ref($slice) eq "slice") ? $slice : $qb->{slice}{$slice} : $qb->sliceOfCube($actCube); print "selektierte slice ", $qb->{slice}{marked}{name}, "\n"; $qb->{slice}{marked}->changeColor(5); } # selSlice }}}2 sub move { # {{{2 my ($qb, $zug) = @_; $zug =~ /(([xyz])\d)(-?\d)/; $qb->{actAxis} = $2; my ($slice, $x) = ($1, $3); $qb->selSlice($slice); $qb->autoRot($x); }; # move }}}2 sub oneSliceRotStep { # {{{2 my ($qb, $steps, $dir) = @_; my $slice = $qb->{slice}{marked}; while ($steps-- > 0) { # Achtung, identischer Baustein in # $canvas->bind('cube', '<B1-Motion>' => # foreach (keys %{$slice->{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"); } main::plotAll(); } } # oneSliceRotStep }}}2 sub plotAllCubes { # {{{2 # The drawing of the individual cubes is done from far to near + # (relative to observers position) to avoid sumptuous object- # clipping-computings. # (gilt das noch ???) # bei einem 5er-cube werden eigentlich verdeckte Polygone ange +- # zeigt. Eine Lösung könnte in der Distanzmessung zur Sicht- # ebene und nicht zum Beobachterpunkt liegen ... my $qb = shift; my ($i, @a, @b) = (0); foreach (@{$qb->{cube}}) { # remember the particular # cubeCenter-observer-distance $_->creaWC; $a[$i] = matob::vNorm($_->{centr}{wx}, $_->{centr}{wy}, $_->{centr}{wz} + $distance) . "_$i"; $b[$i++] = $_; } no warnings; # perl grumbles, foreach (sort {$b <=> $a} @a) { # but does the demanded # numerical sort /._(\d+)$/; $b[$1]->plot; } use warnings; } # plotAllCubes }}}2 sub randMove { # {{{2 my $qb = shift; my ($x, $slice); $qb->{actAxis} = [qw/x y z/]->[int(rand(3))]; my $n = int(rand($qbCubes))+1; $slice = sprintf("%1s%1d", $qb->{actAxis}, $n); #$qb->{slice}{gripped} = $slice; $qb->selSlice($slice); do {$x = int(rand(7)) - 3} until $x; $zug = $slice . sprintf("%2d *", $x); $zug =~ s/\s//; [$zug, $x]; }; # randMove }}}2 sub shuffle { # {{{2 my ($qb, $shuffleSteps, $movLBox) = @_; my ($zn, $i, $zug, $x) = (1, 0); while ($i++ < $shuffleSteps) { my $rA = $qb->randMove; ($zug, $x) = @$rA; $qb->autoRot($x); my $zn = $movLBox->index('end') + 1; $zug = sprintf("%4d: %5s", $zn, $zug); $movLBox->insert('end', $zug); $movLBox->see('end'); $qb->{shuffleBreak} && do { $qb->{shuffleBreak +} = 0; last; }; #sleep 1; }; }; # shuffle }}}2 sub showAttr { # {{{2 my $qb = shift; print Dumper($qb); }; #showAttr }}}2 sub save { # {{{2 my ($qb, $fname, $movLBox) = @_; $canvas->configure(-cursor => 'watch'); $fname =~ s/\.q(?:sn|po|mv)$//; $fname ||= "noname"; #$fname = "noname"; print "saving $fname ... "; # qsn : SNap open (O, ">$fname.qsn"); $Data::Dumper::Purity = 1; print O Data::Dumper->Dump([$qb], ['qb']); close O; # qmv : MoVes my @moves = $movLBox->get(0, 'end'); open (O, ">$fname.qmv"); print O "$_\n" for @moves; close O; # qpo : POsition open (O, ">$fname.qpo"); $Data::Dumper::Purity = 1; print O Data::Dumper->Dump([$mm], ['mm']); close O; print "done\n"; $saveIt = 0; }; #save }}}2 sub updSlices { # {{{2 return if keys %{$qb->{constraint}}; print "updSlices start\n"; foreach my $j (qw(x y z)) { $j eq $qb->{actAxis} && next; for (my $i = 1; $i <= $qbCubes; $i++) { $qb->{slice}{$j . $i}{val} ||= $qb->{n2s}[$i]; $qb->{slice}{$j . $i}->members(); }; }; print "updSlices end\n"; }; #updSlices }}}2 sub sliceOfCube { # {{{2 my ($qb, $cube) = @_; $cube ||= $actCube; #print "\$cube: $cube\n"; my $val = $qb->{cube}[$cube]{centr}{"l" . $qb->{actAxis}}; #print "\$val: $val\n"; my $slice = $qb->{actAxis} . $qb->{s2n}{$val}; #$qb->{slice}{$slice}->showAttr; $qb->{slice}{$slice}; }; #sliceOfCube }}}2 sub undoMove { # {{{2 my ($qb, $rZug) = @_; $rZug =~ s/,-/, / || $rZug =~ s/, /,-/; $qb->move($rZug); }; # undoMove }}}2 # package qb; }}}1

In reply to "Rubics Cube" game by tos

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others cooling their heels in the Monastery: (2)
As of 2021-12-06 06:18 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    R or B?



    Results (31 votes). Check out past polls.

    Notices?