From c6f972110da1c7916f5f35c7c5bf0695852d42df Mon Sep 17 00:00:00 2001 From: Stephan Barth Date: Fri, 22 Dec 2023 15:37:48 +0100 Subject: [PATCH] Initialer Commit. --- Manticore/Mantis.pm | 216 +++++++++++++++++ doc/curveformulae | 67 ++++++ fonts/refont/.IconOK.ff.swp | Bin 0 -> 12288 bytes .../refont/IconCourseFavouriteAutomatic.mant | 7 + fonts/refont/IconCourseFavouriteManual.mant | 4 + fonts/refont/IconCourseFavouriteOff.mant | 8 + fonts/refont/IconLanguage.mant | 6 + fonts/refont/IconNotOK.mant | 5 + fonts/refont/IconOK.mant | 5 + fonts/refont/IconProblem.mant | 3 + fonts/refont/IconVisible.mant | 5 + fonts/refont/IconWarning.mant | 7 + fonts/uwx/I.mant | 7 + fonts/uwx/N.mant | 7 + fonts/uwx/O.mant | 11 + fonts/uwx/R.mant | 13 + fonts/uwx/R2.mant | 14 ++ fonts/uwx/R3.mant | 14 ++ fonts/uwx/U.mant | 6 + fonts/uwx/W.mant | 9 + fonts/uwx/X.mant | 5 + iconize.pl | 54 +++++ manticore.pl | 224 ++++++++++++++++++ uniworx.pl | 189 +++++++++++++++ 24 files changed, 886 insertions(+) create mode 100644 Manticore/Mantis.pm create mode 100644 doc/curveformulae create mode 100644 fonts/refont/.IconOK.ff.swp create mode 100644 fonts/refont/IconCourseFavouriteAutomatic.mant create mode 100644 fonts/refont/IconCourseFavouriteManual.mant create mode 100644 fonts/refont/IconCourseFavouriteOff.mant create mode 100644 fonts/refont/IconLanguage.mant create mode 100644 fonts/refont/IconNotOK.mant create mode 100644 fonts/refont/IconOK.mant create mode 100644 fonts/refont/IconProblem.mant create mode 100644 fonts/refont/IconVisible.mant create mode 100644 fonts/refont/IconWarning.mant create mode 100644 fonts/uwx/I.mant create mode 100644 fonts/uwx/N.mant create mode 100644 fonts/uwx/O.mant create mode 100644 fonts/uwx/R.mant create mode 100644 fonts/uwx/R2.mant create mode 100644 fonts/uwx/R3.mant create mode 100644 fonts/uwx/U.mant create mode 100644 fonts/uwx/W.mant create mode 100644 fonts/uwx/X.mant create mode 100755 iconize.pl create mode 100755 manticore.pl create mode 100755 uniworx.pl diff --git a/Manticore/Mantis.pm b/Manticore/Mantis.pm new file mode 100644 index 0000000..e0375bf --- /dev/null +++ b/Manticore/Mantis.pm @@ -0,0 +1,216 @@ +package Manticore::Mantis; + +use strict; +use warnings; +use Math::Trig; + +our %font; + +my %curvefunctions = ( + curve => sub { + my $ratio = shift; + return ($ratio, 1-$ratio, $ratio) + }, + smooth => sub { + my $ratio = shift; + my $sr = 0; + if($ratio < 0) { + $sr = 0 + } elsif($ratio > 1) { + $sr = 1 + } else { + my $sq = $ratio*$ratio; + $sr = -2*$ratio*$sq+3*$sq + } + return ($ratio, 1-$ratio, $sr); + }, + circ => sub { + # On a right angled curve point that has both ends at the same location we get a perfect circle + # formula derived on a sheet of paper + my $ratio = shift; + my $pirat = $ratio*pi/2; + my $s = sin $pirat; + my $c = cos $pirat; + my $ratV = ($c + $s*($s-1)/$c); + my $ratU = ($s - $c*(1-$c)/$s); + my $dxU = $s*($s-1)/$c; + my $dyU = 1-$s; + my $dxV = 1-$c; + my $dyV = $c*(1-$c)/$s; + my $l2 = sqrt($dxU*$dxU + $dyU*$dyU); + my $l1 = sqrt($dxV*$dxV + $dyV*$dyV); + #print "[[ $ratio -> $ratU $ratV $l1 $l2 ]]\n"; + return + ( + $ratU, + $ratV, + $l1/($l1+$l2) + #$ratio + ) + }, +); +my $re_curves = join '|', keys %curvefunctions; +$re_curves = qr((?:$re_curves)); + +sub fontLoader { + my %p = @_; + my $lambdaw2a = $p{lambdaw2a} || 0.46; + my $lambdaw2b = $p{lambdaw2b} || 0.28; + %font = ( + W2=>{ + data => [ + [[0+3*$lambdaw2a,0+6*$lambdaw2a], [1+3*$lambdaw2b,0+6*$lambdaw2b], [4,6], [3,6]], + [[3,6], [4,6], [5.5,3.2], [4.5,3.2]], + [[4.5,3.2], [5.5,3.2], [7,6], [6,6]], + [[6,6], [7,6], [10,0], [9,0]], + ] + }, + ); + if(my $dir = $p{dir}) { + my $dh = undef; + opendir($dh, $dir) or die "Could not read directory '$dir', because: $!"; + while(my $fn = readdir($dh)) { + next unless $fn=~m#(.*)\.mant$#; + my $gly = $1; + my $fullfile = "$dir/$fn"; + my $fh = undef; + open($fh, '<', $fullfile) or die "Could not read file '$fullfile', because: $!"; + my @blocks = ([]); + while(my $line = <$fh>) { + if($line=~m#^===#) { + push @blocks, [] + } else { + push @{$blocks[-1]}, $line + } + } + my ($head) = @{shift @blocks}; + if($head=~m#^(\S+)#) { + die "Head glyphem identifier does not equal file name in '$fullfile' ('$1' vs. '$gly')" unless $1 eq $gly + } else { + die "Malformed head in file $fullfile" + } + $font{$gly}{data} = [map {rowText2data(join '', @$_)} @blocks] + } + } +} + +sub font { return %font } + +# return display data out of a glyphem name +sub glyphemDisplay { + my $gly = shift; + #return [map {[map {@$_} @$_]} @{$font{$gly}{data}}]; + my $data = glyphemData($gly); + return undef unless defined $data; + return [map {rowData2display($_)} @$data] +} + +# return definition data out of a glyphem name +sub glyphemData { + my $gly = shift; + return $font{$gly}{data}; +} + +# Glyphems are stored per line and in the modes +# text -- the textual representation +# data -- the complete data representation +# display -- display mode as flattened coordinate list +# Conversion subs are +# rowData2text, rowText2data, rowData2display +# as Display is information rendered into linear vectors there is no rowDisplay2data + +sub rowData2text { + my $fg = shift; + my @text = (); + for my $i(0..$#$fg) { + my $point = $fg->[$i]; + if('ARRAY' eq ref $point) { + $point = "$point->[0],$point->[1]" + } elsif('HASH' eq ref $point) { + $point = "$point->{fun}($point->{par})"; + } + push @text, $point; + } + my $astext = ''; + #join ' ', @text; + for(0..$#text) { + $astext .= $text[$_]; + if($_ != $#text) { + $astext .= (5 != $_ % 6) ? " " : "\n" + } + } + return $astext; +} + +# generate a data row out of a content block +sub rowText2data { + my $content = shift; + my @blocks = (); + $content=~s#(-?[0-9\.]+,-?[0-9\.]+|$re_curves\([0-9]+\))#push @blocks,$1;""#ge; + if($content!~m#^\s*$#) { + warn "Leftover characters: $content" + #print "<<@blocks>> [[$content]]\n" + } + my @lblock = map { + my $ret = undef; + if(m#(.*),(.*)#) { + $ret = [$1,$2] + } elsif(m#([a-z]+)\(([0-9]+)\)#) { + $ret = {fun=>$1, par=>$2} + } else { + die "Illegal data state (\$content was preparsed but that did let pass the illegal string '$_')"; + } + $ret + } @blocks; + return \@lblock; +} + + +sub rowData2display { + my $i = shift; + #return [map {@$_} @$i] + my @dis = @$i; + my @ret = (); + for(0..$#dis) { + my $pre = $dis[$_-4]; + my $xy0 = $dis[$_-3]; + my $here = $dis[$_-2]; + my $xy1 = $dis[$_-1]; + my $post = $dis[$_]; + if('ARRAY' eq ref $here) { + if('ARRAY' eq ref $xy0 and 'ARRAY' eq ref $xy1) { + push @ret, @$here; # normal point context, we don't do anything fancy + } else { + # intentionally empty as we use this point for context of the function and not for something else + } + } elsif('HASH' eq ref $here) { + if('ARRAY' eq ref $xy0 and 'ARRAY' eq ref $xy1 and 'ARRAY' eq ref $post and 'ARRAY' eq ref $pre) { + my $func = $curvefunctions{$here->{fun}}; + my $count = $here->{par}; + # Old code state: function is curve, as we do not support anything else so far + # TODO New code state: func contains a function ratio -> ratio in line 1 -> ratio in line 2 -> ratio between lines + #print "===\n"; + for my $lambda(1..$count) { + my $preratio = $lambda/($count+1); + #my $s = sin($ratio*pi/2); + #my $c = cos($ratio*pi/2); + my ($ratio, $r1, $rel1) = $func->($preratio); + my $rel2 = 1-$rel1; + #my $r1 = 1-$ratio; + my $xypre = [$pre->[0]*(1-$ratio) + $xy0->[0]*$ratio, $pre->[1]*(1-$ratio) + $xy0->[1]*$ratio]; + my $xypost = [$post->[0]*(1-$r1) + $xy1->[0]*$r1, $post->[1]*(1-$r1) + $xy1->[1]*$r1]; + my $pushy = [$xypre->[0]*$rel2 + $xypost->[0]*$rel1, $xypre->[1]*$rel2 + $xypost->[1]*$rel1,]; + #print "<<$ratio $r1 -- [@$pre !! @$xy0] [@$xy1 !! @$post]\n [@$xypre] [@$xypost]\n [@$pushy]>>\n"; + push @ret, @$pushy; + } + } else { + die "Illegal data, probably two functions too close to each other" + } + } else { + die "illegal data: neither ARRAY nor HASH"; + } + } + return \@ret +} + +1; diff --git a/doc/curveformulae b/doc/curveformulae new file mode 100644 index 0000000..1cc524c --- /dev/null +++ b/doc/curveformulae @@ -0,0 +1,67 @@ +Curves are a transition from one line to another such that a curved line +emerges. +For doing so one needs to interpolate between 4 points. + +curve is a simple curve with linear interpolation twice; +looks quite curvy anyway + +smooth is a smoother interpolation with continous derivations at its end +when continuing with the constant 0 or 1 function + +f(0) = 0 +f(1) = 1 +f'(0) = 0 +f'(1) = 0 + +f = bx^3+cx^2+dx+e +f' = 3bx^2 + 2cx + d + +f(0) = 0 -> e=0 +f(1) = 1 -> b+c+d+e = 1 +f'(0) = 0 -> d = 0 +f'(1) = 0 -> 3b+2c+d = 0 + +b+c = 1 +3b+2c = 0 + +c = 3 +b = -2 + +-2*$x*$x*$x+3*$x*$x + +circ is an interpolation that results in a proper quarter circle when +used on two interpolation base lines of the same length that have a +common vertex + + \ + \ +--------U----+ +-----....\ | + "X | + \\ | + \\| + |V + ||\ + || \ + +X = (cos phi, sin phi) = (x,y) + +l = (x + µ y, y - µ y) + +U = (x + µ1 y, y - µ1 x = 1) +V = (x + µ2 y = 1, y - µ2 x) + +µ1 = (y-1)/x +µ2 = (1-x)/y + +U = (x + y(y-1)/x, 1) +V = (1, y - x(1-x)/y) + +dxU = y(y-1)/x +dyU = 1-y +dxV = 1-x +dyV = x(1-x)/y + +l1 = sqrt (dxU*dxU + dyU*dyU) +l2 = sqrt (dxV*dxV + dyV*dyV) + diff --git a/fonts/refont/.IconOK.ff.swp b/fonts/refont/.IconOK.ff.swp new file mode 100644 index 0000000000000000000000000000000000000000..9dfdb1ef2e8d7546935cd0b743713c79c091af41 GIT binary patch literal 12288 zcmeI&Jxatt6u|Mf!j_`w1x9U$WRsXI7JGn2#7avcuE`o?lO;(bf)-xEdkEr5EClbN zg`Jbx2;vrN8~G2s`F#19AEXG$`QUVXqz;^cn6fEy_HdItKfTLaKa{Mxyo#Io6{XIq z6&Z`=TYExxUKZ0bp3SnPOmcUc)jwz4G|ng2X_41%Q&n!6*ui*G+sj!VCfkAbgwV>&|}C>1$=sC`q(XfzT}?new(); +my $can = $main->Canvas(-width=>1000,-height=>900,-background=>'#aaaaaa')->pack(); + +Manticore::Mantis::fontLoader(dir=>"fonts/refont"); + + +show(); + +MainLoop; + +sub show { + my $x = 0; + my $y = 0; + my $distx = 230; + my $disty = 39; + for(qw(IconNew IconOK IconNotOK IconWarning IconProblem IconVisible IconInvisible IconCourseFavouriteManual IconCourseFavouriteAutomatic IconCourseFavouriteOff IconEnrolTrue IconEnrolFalse IconPlanned IconAnnounce IconExam IconExamRegisterTrue IconExamRegisterFalse IconExamAutoOccurrenceNudgeUp IconExamAutoOccurrenceNudgeDown IconExamAutoOccurrenceIgnore IconExamAutoOccurrenceReconsider IconCommentTrue IconCommentFalse IconLink IconFileDownload IconFileUpload IconFileZip IconFileCSV IconSFTQuestion IconSFTHint IconSFTSolution IconSFTMarking IconEmail IconRegisterTemplate IconNoCorrectors IconRemoveUser IconTooltipDefault IconNotificationSuccess IconNotificationInfo IconNotificationWarning IconNotificationError IconNotificationNonactive IconFavourite IconLanguage IconNavContainerClose IconPageActionChildrenClose IconMenuNews IconMenuHelp IconMenuProfile IconMenuLogin IconMenuLogout IconBreadcrumbsHome IconMenuExtra IconMenuCourseList IconMenuCorrections IconMenuExams IconMenuAdmin IconMenuLms IconMenuQualification IconPageActionPrimaryExpand IconPageActionSecondary IconBreadcrumbSeparator IconFileUploadSession IconStandaloneFieldError IconFileUser IconNotification IconNotificationSent IconNoNotification IconPersonalIdentification IconMenuWorkflows IconVideo IconSubmissionUserDuplicate IconSubmissionNoUsers IconReset IconBlocked IconCertificate IconPrintCenter IconLetter IconAt IconSupervisor IconSupervisorForeign IconExpired IconLocked IconUnlocked IconResetTries IconCompany IconEdit IconUserEdit)) { + $can->createText(45+$x*$distx,12+$y*$disty,-text=>$_,-anchor=>'w'); + my $icon = Manticore::Mantis::glyphemDisplay($_); + if($icon) { + for my $ic(@$icon) { + my @newpoly = (); + my $xy = 1; + for(@$ic) { + push @newpoly, ($xy + ? ($_*6+0+$x*$distx) + : ($_*6-12+$y*$disty) + ); + $xy = $xy ? 0 : 1; + } + $can->createPolygon(@newpoly, -fill=>'#000000', -outline=>undef); + } + } + $y++; + if($y > 22) { + $y = 0; + $x++; + } +} +} diff --git a/manticore.pl b/manticore.pl new file mode 100755 index 0000000..a137b6a --- /dev/null +++ b/manticore.pl @@ -0,0 +1,224 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Tk; + +# Wir wollen keine , in Dezimalbruechen. Wer kommt nur auf solche Ideen? +use POSIX; +setlocale(LC_NUMERIC, "C"); + +BEGIN { + unshift @INC, '.'; +}; + +use Manticore::Mantis; + +my $sticky = 0; +my $helplines = "1:2"; + +#my @display = (); +my @edit = (); +#( +# [2.3,3, 3.3,3, 4.8,6, 3.8,6], +# [0,6, 1,6, 4,0, 3,0], +# [2,2.5, 4,2.5, 4,3.5, 2,3.5], +# [5,1, 3,1, 3,0, 5.5,0, 6,0.5, 6.25,1, 5.125,3.25, 4.5,3.5, 3,3.5, 3,2.5, 4.575,2.5, 5.2,1.25,], +#); +my $fgi = 1; + +my $gl = shift @ARGV; +$gl = 'W' unless defined $gl; +if(defined $gl) { + my $path = "fonts/uwx"; + my $icon = $gl; + if($gl=~m#(.*)/(.*)\.mant#) { + $path = $1; + $icon = $2; + } + Manticore::Mantis::fontLoader(dir=>$path); + #@bg = @{$Manticore::Mantis::font{$gl}{data}}; + #@display = @{Manticore::Mantis::glyphemDisplay($gl)}; + @edit = @{Manticore::Mantis::glyphemData($icon)}; + $fgi = 0; +} + +my $offset = 60; + +my $scale = 80; + +my $main = MainWindow->new(); + +my $can = $main->Canvas(-background=>'#ffffff',-width=>700,-height=>700)->pack(-side=>'left'); + +my $frame = $main->Frame->pack(-side=>'left'); + +for my $i(0..$#edit) { + #my $rowdata = $display[$i]; + my $row = $frame->Frame->pack; + $row->Radiobutton(-value=>$i, -variable=>\$fgi, -command=>sub {draw(); loadtextblock()})->pack; +} + +my $textarea = $frame->Text->pack(); + +$frame->Button(-text=>'apply', -command=>sub { usetextblock(); draw() })->pack(); + +$frame->Label(-text=>'Sticky')->pack; +my $stickyframe = $frame->Frame->pack; + +for(['None', 0], [1,1], [2,2], [4,4], [8,8]) { + $stickyframe->Radiobutton(-text=>$_->[0],-value=>$_->[1],-variable=>\$sticky)->pack(-side=>'left'); +} + +$frame->Label(-text=>'Help lines')->pack; +my $helplineframe = $frame->Frame->pack; +for("1:2", "1:1") { + $helplineframe->Radiobutton(-text=>$_,-value=>$_,-variable=>\$helplines, -command=>sub {draw()})->pack(-side=>'left'); +} + +sub one { + my ($data, $col, $hl) = @_; + my $display = Manticore::Mantis::rowData2display($data); + $can->createPolygon((map {$_*$scale+$offset} @$display), -fill=>$col, -outline=>undef); + if($hl) { + for(0..$#$data) { + my $xy0 = $data->[$_-1]; + my $xy1 = $data->[$_]; + next unless 'ARRAY' eq ref $xy0; + next unless 'ARRAY' eq ref $xy1; + my $x0 = $xy0->[0]; + my $y0 = $xy0->[1]; + my $x1 = $xy1->[0]; + my $y1 = $xy1->[1]; + my $dx = abs($x1-$x0); + my $dy = abs($y1-$y0); + my $epsilon = 0.0000001; + my $horvert = $dx < $epsilon || $dy < $epsilon; + my $diag = sub {'1:2' eq $helplines + ? abs($dx/$dy-2) < $epsilon || abs($dy/$dx-2) < $epsilon + : abs($dx/$dy-1) < $epsilon && abs($dy/$dx-1) < $epsilon + } + ; + if($horvert || $diag->()) { + $can->createLine((map {$_*$scale+$offset} ($x0,$y0,$x1,$y1)), -fill=>'#0000ff', -width=>4); + } else { + $can->createLine((map {$_*$scale+$offset} ($x0,$y0,$x1,$y1)), -fill=>'#888888', -width=>2); + } + } + } +} + +sub draw { + $can->delete('all'); + one($_,'#444444', 0) for @edit; + one($edit[$fgi], '#aaaa00', 1); + for my $cx(0..20) { + my $x = $cx*$scale+$offset; + for my $cy(0..20) { + my $y = $cy*$scale+$offset; + $can->createOval($x-5,$y-5,$x+5,$y+5,-fill=>'#0000aa',-outline=>undef); + } + } + my $fg = $edit[$fgi]; + for my $i(0..$#$fg) { + my $xy = $fg->[$i]; + next unless 'ARRAY' eq ref $xy; + my $cx = $xy->[0]; + my $cy = $xy->[1]; + my $x = $cx*$scale+$offset; + my $y = $cy*$scale+$offset; + $can->createOval($x-7,$y-7,$x+7,$y+7,-fill=>'#bb0000',-outline=>undef); + $i += 2; + } +} + +draw(); +loadtextblock(); + +my $pressed = 0; +my $pressedInd = undef; + +$can->Tk::bind('<1>'=>[sub { + my (undef,$x,$y) = @_; + ($x,$y) = map {($_-$offset)/$scale} ($x,$y); + my ($eins) = closest($x,$y); + $pressedInd = $eins; + $pressed = 1; + #@{$display[$fgi]}[$pressedInd,$pressedInd+1] = ($x,$y); + $edit[$fgi][$pressedInd] = makeSticky([$x,$y]); + draw(); +}, Ev('x'), Ev('y')]); +$can->Tk::bind(''=>[sub { + return unless $pressed; + my (undef,$x,$y) = @_; + ($x,$y) = map {($_-$offset)/$scale} ($x,$y); + #@{$display[$fgi]}[$pressedInd,$pressedInd+1] = ($x,$y); + $edit[$fgi][$pressedInd] = makeSticky([$x,$y]); + draw(); +}, Ev('x'), Ev('y')]); +$can->Tk::bind(''=>sub {$pressed = 0}); +$can->Tk::bind('<3>'=>[sub { + my (undef,$x,$y) = @_; + ($x,$y) = map {($_-$offset)/$scale} ($x,$y); + my ($eins,$zwei) = closest($x,$y); + my $fg = $edit[$fgi]; + my $xy1 = $fg->[$eins]; + my ($x1,$y1) = @{$xy1}; + my $dx = $x-$x1; + my $dy = $y-$y1; + if($dx*$dx + $dy*$dy < 0.01) { + splice(@$fg, $eins, 1); + } else { + print "<$eins $zwei>\n"; + my $newind = 0; + if($zwei > $eins || 0==$zwei) { + $newind = $eins+1 + } else { + $newind = $zwei+1 + } + splice(@$fg, $newind, 0, [$x,$y]); + } + draw(); +}, Ev('x'), Ev('y')]); + +# return the ids from the closet entry to the farest +sub closest { + my ($x,$y) = @_; + my $fg = $edit[$fgi]; + my @dists = (); + for my $i(0..$#$fg) { + my $txy = $fg->[$i]; + next unless 'ARRAY' eq ref $txy; + my $tx = $txy->[0]; + my $ty = $txy->[1]; + my $dx = $x-$tx; + my $dy = $y-$ty; + push @dists, [$dx*$dx+$dy*$dy, $i, $tx,$ty]; + } + @dists = sort {$a->[0] <=> $b->[0]} @dists; + map {$_->[1]} @dists +} + +MainLoop; + +sub makeSticky { + my $xy = shift; + my $x = $xy->[0]; + my $y = $xy->[1]; + if($sticky > 0.5) { + $_ = POSIX::floor($_*$sticky+0.5)/$sticky for $x,$y + } + return [$x,$y] +} + +sub loadtextblock { + $textarea->delete('1.0','end'); + $textarea->insert('end', Manticore::Mantis::rowData2text($edit[$fgi])); +} + +sub usetextblock { + my $content = $textarea->get('1.0', 'end'); + $edit[$fgi] = Manticore::Mantis::rowText2data($content); +} + + diff --git a/uniworx.pl b/uniworx.pl new file mode 100755 index 0000000..ea0fd4e --- /dev/null +++ b/uniworx.pl @@ -0,0 +1,189 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Tk; + +use Data::Dumper; + +# Wir wollen keine , in Dezimalbruechen. Wer kommt nur auf solche Ideen? +use POSIX; +setlocale(LC_NUMERIC, "C"); + +BEGIN { + unshift @INC, '.'; +}; + +use Manticore::Mantis; + +#my %font = (); + +my $logoDist = 0; +my $logoDist2 = 0; + +sub refont { + Manticore::Mantis::fontLoader(dir => "fonts/uwx"); +} + +refont(); + +my $graysim = 0; + +sub col { + my ($R,$G,$B,$mkgray) = @_; + if($mkgray) { + my $mid = ($R+$G+$B)/3; + $R = $mid; + $G = $mid; + $B = $mid; + } + my $r = int($R*255); + my $g = int($G*255); + my $b = int($B*255); + for($r,$g,$b) { $_=0 if $_<0; $_=255 if $_>255 } + sprintf("#%02x%02x%02x",$r,$g,$b); +} + +my $main = MainWindow->new(); + +my $can = $main->Canvas(-background=>'#ffffff',-width=>700,-height=>700)->pack(-side=>'left'); +my $scrolls = $main->Frame(-width=>350,-height=>300,-background=>'#000000')->pack(-side=>'left',-expand=>0); + +#$scrolls->Label(-text=>" ")->pack; + +#renderOutline(5, 425,200,30, "X", '#000000'); +#render(425,200,30, "X", '#ff0000'); +#renderOutline(5, 200,200,30, "W", '#000000'); +#render(200,200,30, "W", '#ff0000'); +#renderOutline(5, 185,200,30, "U", '#000000'); +#render(185,200,30, "U", '#ff0000'); + + +#renderOutline(5, 415,200,30, "X", '#000000'); +#render(415,200,30, "X", '#553080'); +#renderOutline(5, 200,200,30, "W", '#000000'); +#render(200,200,30, "W", '#88409e'); +#renderOutline(5, 195,200,30, "U", '#000000'); +#render(195,200,30, "U", '#aa50bb'); + +#my $r1 = 0.3; +#my $g1 = 0.3; +#my $b1 = 0.8; +#my $r0 = 0.55; +#my $g0 = 0.15; +#my $b0 = 0.15; + +#$scrolls->Checkbutton(-text=>'draw grayscale',-variable=>\$graysim,-command=>sub {renderAll()})->pack; + +my $r1 = 0.4; +my $g1 = 0.4; +my $b1 = 0.8; +my $r0 = 0.2; +my $g0 = 0.2; +my $b0 = 0.5; + +for( + ['r',\$r0,'#ff0000'], + ['g',\$g0,'#00ff00'], + ['b',\$b0,'#0000ff'], + ['r',\$r1,'#ff0000'], + ['g',\$g1,'#00ff00'], + ['b',\$b1,'#0000ff'], +) { + #$scrolls->Scrollbar(-orient=>'horizontal')->pack(-fill=>'x'); + my $row = $scrolls->Frame->pack(-fill=>'x'); + $row->Label(-text=>$_->[0],-width=>2,-background=>$_->[2])->pack(-side=>'left'); + #$row->Scrollbar(-orient=>'horizontal',-command=>sub {print "[[ @_ ]]\n"; return 1})->pack(-expand=>1,-fill=>'x',-side=>'left'); + my $vb = $_->[1]; + $row->Scale(-orient=>'horizontal',-length=>200,-variable=>$vb,-resolution=>-1,-from=>0,-to=>1, + -command=>sub { + my $v = shift; + #print "[[ @_ ]]\n"; return 1 + #$$vb = $v/100; + renderAll(); + })->pack(-side=>'left') +} + +$scrolls->Scale(-orient=>'horizontal',-length=>200,-variable=>\$logoDist,-resolution=>-1,-from=>0,-to=>100, + -command=>sub { + renderAll(); + })->pack(); +$scrolls->Scale(-orient=>'horizontal',-length=>200,-variable=>\$logoDist2,-resolution=>-1,-from=>-20,-to=>20, + -command=>sub { + renderAll(); + })->pack(); + +my $dunkelbg = '#333333'; +my $hellbg = '#cccccc'; + +sub renderAll { + $can->delete('all'); + + renderOutline(5, 415+$logoDist,120,30, "X", [$dunkelbg, $hellbg, $hellbg, $dunkelbg]); + render(415+$logoDist,120,30, "X", col($r0,$g0,$b0,0)); + renderOutline(5, 200,120,30, "W", [$dunkelbg, $hellbg, $hellbg, $dunkelbg]); + render(200,120,30, "W", col(($r0+$r1)/2,($g0+$g1)/2,($b0+$b1)/2,0)); + renderOutline(5, 165-$logoDist,120,30, "U", [$dunkelbg, $hellbg, $hellbg, $dunkelbg]); + render(165-$logoDist,120,30, "U", col($r1,$g1,$b1,0)); + + renderOutline(5, 415+$logoDist,340,30, "X", [$dunkelbg, $hellbg, $hellbg, $dunkelbg]); + render(415+$logoDist,340,30, "X", col($r0,$g0,$b0,1)); + renderOutline(5, 200,340,30, "W", [$dunkelbg, $hellbg, $hellbg, $dunkelbg]); + render(200,340,30, "W", col(($r0+$r1)/2,($g0+$g1)/2,($b0+$b1)/2,1)); + renderOutline(5, 165-$logoDist,340,30, "U", [$dunkelbg, $hellbg, $hellbg, $dunkelbg]); + render(165-$logoDist,340,30, "U", col($r1,$g1,$b1,1)); + + # renderOutline(5, 120,220,50, "R", [$dunkelbg, $hellbg, $hellbg, $dunkelbg]); + #render(120,220,50, "R", col(0.5,1,0,0)); + + my $i = 0; + for my $c(reverse ( + [185,0.0,"U"], + [235,0.1666,"N"], + [285,0.3333,"I"], + [320,0.5,"W2"], + [410,0.6666,"O"], + [450,0.8333,"R"], + [502,1,"X"], + )) { + my $dx = $i*$logoDist2; + $i++; + renderOutline(2, $c->[0]+$dx,570,10, $c->[2], [$dunkelbg, $hellbg, $hellbg, $dunkelbg]); + render($c->[0]+$dx,570,10, $c->[2], col($r0*$c->[1]+$r1*(1-$c->[1]),$g0*$c->[1]+$g1*(1-$c->[1]),$b0*$c->[1]+$b1*(1-$c->[1]),0)); + } +} + +renderAll(); + + + +MainLoop; + +sub renderOutline { + my ($diff, $x, $y, $size, $letter, $col) = @_; + my @where = ( + [$diff,-$diff], + [-$diff,-$diff], + [-$diff,$diff], + [$diff,$diff], + ); + for(0..$#where) { + my ($dx, $dy) = @{$where[$_]}; + my $scol = ref $col ? $col->[$_] : $col; + render($dx+$x, $dy+$y, $size, $letter, $scol); + } +} + +sub render { + my ($x,$y,$scale,$t, $col) = @_; + my $font = Manticore::Mantis::glyphemDisplay($t) or die "Letter not found: $t"; + #print Data::Dumper::Dumper($font); + for my $frag(@{$font}) { + my @newpoly = map {$scale*$_} @{$frag}; + for(0..$#newpoly) { + $newpoly[$_] += ($_ % 2) == 0 ? $x : $y + } + $can->createPolygon(@newpoly, -fill=>$col, -outline=>undef); + } +} +