manticore/Manticore/Mantis.pm

package Manticore::Mantis;

use strict;
use warnings;
use Math::Trig;

use Manticore::Layer;

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));

# split into ===-separated blocks
sub splitIntoBlocks {
  my $inp = shift;
  my @blocks = ([]);
  for my $line(@$inp) {
    if($line=~m#^===#) {
      push @blocks, [$line]
    } else {
      push @{$blocks[-1]}, $line
    }
  }
  return \@blocks
}

# returns a layer read from a file
sub loadFile {
  my $fn = shift;
  my $fh = undef;
  open($fh, '<', $fn) or die "Could not read file '$fn', because: $!";
#  my @blocks = ([]);
#  while(my $line = <$fh>) {
#    chomp $line;
#    if($line=~m#^===#) {
#      push @blocks, [$line]
#    } else {
#      push @{$blocks[-1]}, $line
#    }
#  }
  my $blocks = splitIntoBlocks([map {chomp} <$fh>]);
  my ($head) = @{shift @$blocks};
  my @blocks = map {loadBlock($_)} @$blocks;
  if(1==@blocks) {
    return [$head, $blocks[0]]
  } else {
    return [$head, Manticore::Layer->fromText('traverse', '', \@blocks)]
  }
}

# format
#  === name
#  cont
#  cont
#  !=== name
#  !cont
#  !=== name
#  !cont
sub loadBlock {
  my $block = shift;
  my @block = @$block;
  my @this = ();
  while(@block and $block[0]!~m#^!#) {
    push @this, shift @block
  }
  s#^!## for @block;
  my $subblocks = splitIntoBlocks(\@block);
  shift @$subblocks;
  my @children = map {loadBlock($_)} @$subblocks;
  my $head = shift @this;
  if($head=~m#===\s*(\S+)#) {
    $head = $1
  } else {
    $head = "traverse"
  }
  Manticore::Layer->fromText($head, (join "\n", @this), \@children);
}

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]
      # TODO above is old code, below is new code, but not working yet
      $font{$gly}{data} = loadFile($fullfile);
    }
  }
}

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;