#!/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
-
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 How to display code and escape characters
are good places to start.
