#!/usr/bin/perl

# Module to read/write CAMM-GL III content

## Copyright (c) 2019-2020 by Thomas Kremer
## License: GPL ver. 2 or 3

package CAMM;

# This implements (a subset of) the CAMM-GL III instruction set "mode 2".

use strict;
use warnings;

use Math::Trig qw(pi);
#use POSIX qw(lround);

use overload '""' => "content";

use constant units_per_mm => 40;
our $units_per_mm = 40;

# escape character for writing strings:
#our $escape_char = "\003";
# examplary slow and fast speed settings:
our $slow = 2;
our $fast = 30;

# named arguments:
#  escape_char: string terminator for text (default: "\003" aka END-OF-TEXT)
#  relative, down, speed, char_size, char_slant, tool,
#    force, p: current state of the machine (is not set automatically).
#  outfile: a file to open for writing (overwrites "f")
#  f: a file to write to (overwrites "output")
#  output: a scalar ref to append commands or a ref to a subroutine
#          (or object) to call for writing commands. (default: new scalar ref)
#  no_timeouts: disable timeout detection that checks the tool after inactivity.

sub new {
  my ($class,%args) = shift;
  if (defined $args{outfile}) {
    open($args{f},">",$args{outfile}) or die "cannot open $args{outfile}: $!";
  }
  if (defined $args{f}) {
    my $f = $args{f};
    $args{output} = sub {
      print $f @_;
    };
  }
  $args{output} //= \(my $s = "");
  $args{$$_[0]} //= $$_[1] for (["relative",0],["escape_char","\x03"],["down",0]);
  return bless \%args, ref $class || $class;
}

sub copy {
  my $self = shift;
  return bless {%$self}, ref $self;
}

package CAMM::Commands {
  # This is a list of bare, stateless commands with parameters,
  # so mostly sprintf-like functions returning CAMM code.
  # Their state logic is managed by the parent module.

  #our $escape_char = "\003";
  sub header { # escape_char
    my $escape_char = $_[0]//"\003";
    "\003\015\012\015\012\015\012\015\012\015\012".
    ";IN;PU;PA0,0;IW0,0,47000,64000;VS30;DT$escape_char;\n";
    # PA isn't a good idea:
    #";IN;PA0,0;IW0,0,47000,64000;VS30;DT$escape_char;\n";
  }
  sub set_escape_char {
    my $escape_char = $_[0];
    "DT$escape_char;\n";
  }
  sub footer {
    moveto(0,0);
  }
  sub tool_up {
    "PU;\n";
  }
  sub tool_down {
    "PD;\n";
  }
  sub set_relative {
    "PR;\n";
  }
  sub set_absolute {
    "PA;\n";
  }
  sub moveto { # x,y
    sprintf "PU%.2f,%.2f;\n", @_;
  }
  sub lineto { # x,y
    sprintf "PD%.2f,%.2f;\n", @_;
  }
  sub polylineto { # x1,y1,x2,y2,...
    "PD".join(",",map {sprintf "%.2f",$_} @_).";\n";
  }
  sub set_speed { # v=2..30 is normal; cm/sec; max 85cm/sec
    sprintf "VS%d;\n", $_[0];
  }
  sub circle { # r; current point is center.
    sprintf "CI%.2f;\n", $_[0];
  }
  sub arc { # Mx,My,angle; radius is such that it includes the current point.
    sprintf "AA%.2f,%.2f,%.2f;\n", @_;
    # FIXED: datasheet says "*1"(float), but other angles are "*3"(float)...
  }
  sub arc_relative { # Mx,My,angle; Mx,My are relative to current point.
    sprintf "AR%.2f,%.2f,%.2f;\n", @_;
    # FIXED: datasheet says "*1"(float), but other angles are "*3"(float)...
  }
  sub moveto_relative { # x,y
    sprintf "PR;PU%.2f,%.2f;\n", @_;
  }
  sub lineto_relative { # x,y
    sprintf "PR;PD%.2f,%.2f;\n", @_;
  }
  sub polylineto_relative { # x1,y1,x2,y2,...
    "PR;PD".join(",",map {sprintf "%.2f",$_} @_).";\n";
  }
  sub set_char_size { # w,h in *cm*
    sprintf "SI%.5f,%.5f;\n", @_;
  }
  sub set_char_slant { # tan(angle)
    sprintf "SL%.2f;", $_[0];
  }
  sub text { # text,escape_char; text must not contain escape_char
    sprintf "LB%s%s\n", $_[0],($_[1]//"\003"); #$escape_char;
  }
  sub tool_change {
    sprintf "SP%d;\n", $_[0];
  }
  sub set_force {
    sprintf "!FS %d\n", floor($_[0]/10)*10;
  }
}

BEGIN {
  # name ? precondition ! postcondition
  # -> to invoke <name>, <precondition> has to be guaranteed.
  # Afterwards, state has changed to establish <postcondition>.
  my @cmdspec = qw(
    header!relative=0!down=0
    footer?relative=0!down=0
    tool_up!down=0
    tool_down!down=1
    moveto?relative=0!down=0
    lineto?relative=0!down=1
    polylineto?relative=0!down=1
    circle?down=1
    arc?down=1!relative=0
    arc_relative?down=1!relative=1
    moveto_relative!relative=1!down=0
    lineto_relative!relative=1!down=1
    polylineto_relative!relative=1!down=1
  );
  #  set_absolute!relative=0
  #  set_relative!relative=1
  #   set_speed
  #   set_char_size
  #   set_char_slant
  #   tool_change
  #   set_force

  my %setters = (
    speed       => \&CAMM::Commands::set_speed,
    char_size   => \&CAMM::Commands::char_size,
    char_slant  => \&CAMM::Commands::char_slant,
    tool        => \&CAMM::Commands::tool_change,
    force       => \&CAMM::Commands::set_force,
    escape_char => \&CAMM::Commands::set_escape_char,
    down => sub { $_[0] ?
        CAMM::Commands::tool_down
      : CAMM::Commands::tool_up;
    },
    relative => sub { $_[0] ?
        CAMM::Commands::set_relative
      : CAMM::Commands::set_absolute;
    },
  );

  # sub set_escape_char {
  #   my ($self,$c) = @_;
  #   $self->{escape_char} = $c;
  #   local $CAMM::Commands::escape_char = $c;
  #   $self->emit(CAMM::Commands::set_escape_char($c));
  # }
  
  # getters, setters.
  for my $name (keys %setters) {
    my $sub = sub {
      return $_[0]->{$name};
    };
    my $settersub = sub {
      $_[0]->set($name,$_[1]);
    };
    my $get_name = "get_$name";
    my $set_name = "set_$name";
    no strict "refs";
    *$name = $sub;
    *$get_name = $sub;
    *$set_name = $settersub;
  }

  sub set {
    my ($self,$name,$value) = @_;
    #   if ($name eq "down") {
    #     $self->emit(
    #       $value ?
    #           CAMM::Commands::tool_down
    #         : CAMM::Commands::tool_up);
    #   } elsif ($name eq "abs") {
    #     $self->emit(
    #       $value ?
    #           CAMM::Commands::set_absolute
    #         : CAMM::Commands::set_relative);
    #  } els
    if (defined $setters{$name}) {
      $self->emit($setters{$name}($value));
    } else {
      die "unknown variable \"$name\"";
    }
    $self->{$name} = $value;
  }

#my $global_object = __PACKAGE__->new;

  for (@cmdspec) {
    my @spec = split /(?=[!?])/, $_;
    my $name = shift @spec;
    my $command = do {
      no strict "refs";
      \&{"CAMM::Commands::$name"};
    };
    my @reqs;
    my @sets;
    for (@spec) {
      if (/^([?!])(\w+)=(\d+)/) {
        my $arr = $1 eq "?" ? \@reqs : \@sets;
        push @$arr, [$2,0+$3];
      } else {
        die "invalid internal spec";
      }
    }
    my $sub = sub {
      #my $self = (@_ && ref $$_[0] eq __PACKAGE__) ? shift : $global_object;
      my $self = shift;
      for (@reqs) {
        if (($self->{$$_[0]}//"-1") != $$_[1]) {
          $self->set($$_[0],$$_[1]);
        }
      }
      $self->emit($command->(@_));
      for (@sets) {
        $self->{$$_[0]} = $$_[1];
      }
    };
    {
      no strict "refs";
      *$name = $sub;
    }
  }

}

sub text {
  #my $self = (@_ && ref $$_[0] eq __PACKAGE__) ? shift : $global_object;
  my $self = shift;
  #local $CAMM::Commands::escape_char = $self->{escape_char};
  $self->emit(CAMM::Commands::text($_[0],$self->{escape_char}));
}

sub emit {
  my ($self,$code) = @_;
  my $out = $self->{output};
  if (ref $out eq "SCALAR") {
    $$out .= $code;
#  } elsif (ref $out eq "CODE") {
  } else {
    # if we've been idle for a couple of seconds, the tool has been upped
    # automatically, so we have to down it again. This only applies to
    # real-time usage and doesn't hurt otherwise, so we just use it in
    # all direct-io cases.
    my $lt = \$self->{lasttime};
    my $t = time;
    if ($$lt+10 > $t && $self->{down} && !$self->{no_timeouts}) {
      $code = CAMM::Commands::tool_down().$code;
    }
    $$lt = $t;
    $out->($code);
  }
}

sub flush {
  my $self = shift;
  my $output = $self->{output};
  if (ref $output eq "SCALAR") {
    my $s = $$output;
    $$output = "";
    return $s;
  }
  return;
}

sub content {
  my $self = shift;
  my $output = $self->{output};
  if (ref $output eq "SCALAR") {
    my $s = $$output;
    return $s;
  }
  return;
}

# $paths = [$polyline,...]
# $polyline = ["open"|"closed",[point,...]]
# options:
#   boolean: header, footer, headerfooter, relative
#   float: epsilon, offset, shortline, smallangle

sub from_polylines {
  my $self = shift;
  $self = $self->new unless ref $self;
  #my $self = (@_ && ref $$_[0] eq __PACKAGE__) ? shift : $global_object;
  my ($paths,%options) = @_;
  @options{qw(header footer)} = (1,1) if $options{headerfooter};
  $self->header() if $options{header};
  my $eps = $options{epsilon}//0.00001;
  for (@$paths) {
    my $points = $$_[1];
    $self->moveto(@{$$points[0]});
    if ($options{offset}) { # if offset = 0, use the other code as well.
      my $offs = $options{offset};
      my $short_line = $options{shortline}//80; # 1.5mm is small.
      my $small_angle = $options{smallangle}//10; # 10° is small.
      my @p = @{$$points[0]};
      my $first = 1;
      for my $i (1..$#$points) {
        my $pt = $$points[$i];
        my @q = ($$pt[0]-$p[0],$$pt[1]-$p[1]);
        my $l = sqrt($q[0]**2+$q[1]**2);
        next unless $l > $eps;
        my @r = @q;
        if ($first) {
          $_ *= 1+$offs/$l for @q;
        }
        $_ *= -$offs/$l for @r;
        @p = @$pt;
        $first = 0;

        # sadly, we can't use relative coordinates here, because we don't
        # know how arc end coordinates are rounded by the device.

        #$res .= CAMM::lineto_relative(@q);
        #$res .= CAMM::lineto($$pt[0],$$pt[1]);
        #my @q_abs = map lround($$pt[$_]-$r[$_]), 0,1;
        my @q_abs = map $$pt[$_]-$r[$_], 0,1;
        $self->lineto(@q_abs);
        for my $j ($i+1 .. $#$points) { # implicit $i < $#$points
          my $pt2 = $$points[$j];
          my @q2 = ($$pt2[0]-$$pt[0],$$pt2[1]-$$pt[1]);
          my $l2 = sqrt($q2[0]**2+$q2[1]**2);
          next unless $l2 > $eps;
          # TODO: since arcs are rather slow, we might want to avoid real
          # arcs here and use a polyline approximation instead.
          # arg(q2/q1) = arg(q2*conj(q1))
          my $angle = 180/pi*
               atan2($q2[1]*$q[0]-$q2[0]*$q[1], $q2[0]*$q[0]+$q2[1]*$q[1]);
          #$res .= arc_relative(@r,$angle);
          # if the angle is small and the next line is short, we assume an
          # interpolated curved line. No need to emphasize the corners.
          if (abs($angle) > $small_angle || $l2 > $short_line) {
            $self->arc(@p,$angle);
          }
          last;
        }
      }
    } else {
      my @coords;
      if ($options{relative}) {
        my @p = @{$$points[0]};
        for (@$points[1..$#$points]) {
          push @coords, $$_[0]-$p[0],$$_[1]-$p[1];
          @p = @$_;
        }
        $self->polylineto_relative(@coords);
      } else {
        @coords = map @$_[0,1], @$points[1..$#$points];
        #$res .= "# ".scalar(@coords)." points;\n";
        $self->polylineto(@coords);
      }
    }
  }
  $self->footer() if $options{footer};
  #return $self->flush();
  return $self;
}

# parsing

my $florex = qr/[-+]?(?:\d+(?:\.\d+)?|\.\d+)(?:[eE][-+]?\d+)?/;

sub _take_token {
  my ($camm,$esc) = @_;
  $$camm =~ s/^\s+//;
  my ($cmd,@args);
  my $check_numeric = 0;
  if ($$camm =~ s/^(?:\^[ \t]*)?([A-Z]{2})//) {
    # mode 2
    $cmd = $1;
    if ($cmd eq "LB" || $cmd eq "WD") {
      my $i = index($$camm,$esc);
      die "unterminated \"$cmd\"." if $i == -1;
      @args = (substr($$camm,0,$i-1));
      substr($$camm,0,$i) = "";
      # $$camm =~ s/^(.*)\Q$esc\E//s;...
    } elsif ($cmd eq "DT") {
      @args = (substr($$camm,0,1));
      $$camm =~ s/^.[^;\n]*;//s;
    } elsif ($$camm =~ s/^([^;]*);//) {
      my $argstr = $1;
      die "line break in argument to \"$cmd\"" if $argstr =~ /\n/;
      @args = split /,/,$argstr;
      $check_numeric = 1;
    } else {
      die "missing semicolon in command \"$cmd\".";
    }
  } elsif ($$camm =~ s/^(![A-Z]{2})(.*)//) { # implicit /$/
    # mode 1 & 2 common
    ($cmd,@args) = ($1,$2);
    $check_numeric = 1;
  } elsif ($$camm =~ s/^\e(\.[A-Z@])//) {
    # device control instructions over RS-232
    $cmd = $1;
    if ($$camm =~ s/^([^:\n]*)://) {
      @args = split /;/, $1;
    }
    $check_numeric = 1;
  } elsif ($$camm =~ s/^([A-Z])//) {
    # mode 1
    $cmd = $1;
    if ($$camm =~ s/^(.*)//) {
      @args = $cmd eq "P" ? ($1) : split /,/,$1;
      $check_numeric = 1 if $cmd ne "P";
    }
  } else {
    return;
  }
  if ($check_numeric) {
    for (@args) {
      if (/^\s*($florex)\s*$/) {
        $_ = $1;
      } else {
        die "non-numerical argument \"$_\" in command \"$cmd\".";
      }
    }
  }
  return ($cmd,\@args);
}

# FIXED: PA,PR,AA,AR don't up/down the pen!
# FIXED: Idleness makes the machine up the pen and not down it again!
#   (therefore we use PU/PD whenever possible.)
# FIXED: The machine can do floating point!
# FIXED: PA/PR influence absoluteness/relativity of PU/PD!
# Note: arcs turn positively leftways (as expected).

our %camm2svg_commands;
{
  my $unimplemented = sub {
    warn "command \"$_[1]\" is not implemented yet.";
  };
  %camm2svg_commands = (
   # command => sub ($context,$command,@arguments)
   #      $context = { p => [$x,$y], d => "", escape_char => "\003" }
    IN => sub {
            @{$_[0]{p}} = (0,0);
            $_[0]{escape_char} = "\003";
            $_[0]{d} .= "M 0,0 ";
          },
    DT => sub { $_[0]{escape_char} = $_[2]; },
    PA => sub {
            $_ = 0+$_ for @_[2..$#_];
            my ($ctx,$cmd,@xy) = @_;
            my $i = {PA=>0,PR=>1,PU=>2,PD=>3}->{$cmd};
            $ctx->{$i&2?"down":"relative"} = $i&1;
            pop @xy if @xy%2 != 0;
            return if !@xy;
            
            my $p = $ctx->{p};
            my $letter = $ctx->{down} ? "l" : "m";
            if ($ctx->{relative}) {
              for (0..$#xy) {
                $$p[$_%2] += $xy[$_];
              }
            } else {
              @$p = @xy[-2,-1];
              $letter = uc($letter);
            }
            $_[0]{d} .= "$letter ".join(",",@xy)." ";
          },
#     PU => sub {
#             $_[0]{down} = 0;
#             pop if @_%2 != 0;
#             return if @_ <= 2;
#             $_ = 0+$_ for @_[2..$#_];
#             @{$_[0]{p}} = @_[-2,-1];
#             $_[0]{d} .= "M ".join(",",@{$_[0]{p}})." ";
#           },
#     PD => sub {
#             $_[0]{down} = 1;
#             pop if @_%2 != 0;
#             return if @_ <= 2;
#             $_ = 0+$_ for @_[2..$#_];
#             @{$_[0]{p}} = @_[-2,-1];
#             $_[0]{d} .= "L ".join(",",@_[2..$#_])." ";
#           },
#     PR => sub {
#             $_[0]{relative} = 1;
#             pop if @_%2 != 0;
#             return if @_ <= 2;
#             $_ = 0+$_ for @_[2..$#_];
#             my $p = $_[0]{p};
#             for (2..$#_) {
#               $$p[$_%2] += $_[$_];
#             }
#             $_[0]{d} .= "l ".join(",",@_[2..$#_])." ";
#           },
    #AA => alias for AR,
    AR => sub {
            $_ = 0+$_ for @_[2..$#_];
            my ($ctx,$cmd,$x,$y,$ang) = @_;
            my $p = $ctx->{p};
            if ($cmd eq "AA") {
              $x -= $$p[0];
              $y -= $$p[1];
            }
            my $r = sqrt($x**2+$y**2);
            my $a1 = atan2(-$y,-$x);
            my $a2 = $a1+$ang/180*pi;
            my $longarc = $ang > 180 ? 1 : 0;
            my $rightways = $ang < 0 ? 0 : 1; # FIXME: svg coord system is left-handed, but we manually flip the y axis to make do....
            my @dp = ($r*(cos($a2)-cos($a1)),$r*(sin($a2)-sin($a1)));
            $$p[$_] += $dp[$_] for 0,1;
            if ($ctx->{down}) {
              $ctx->{d} .= "a $r,$r,0,$longarc,$rightways,".join(",",@dp)." ";
            } else {
              $ctx->{d} .= "m ".join(",",@dp)." ";
            }
          },
    CI => sub {
            return unless $_[0]{down};
            $_ = 0+$_ for @_[2..$#_];
            my $r = $_[2];
            $_[0]{d} .= "m $r,0 a $r,$r,0,0,0,".(-2*$r).",0 ".
                         "a $r,$r,0,0,0,".(2*$r).",0 z m ".(-$r).",0 ";
          },

    IW => sub { # need to implement this because it is in our header.
            my ($ctx,$cmd,@args) = @_;
            $ctx->{input_window} = [@args];
            #"IW0,0,47000,64000;";
          },
    map({$_ => 0} qw(
      OA OC OE OF OH OI OO OP OS OW SS SP VS
      !FS !NR !PG !ST
      .B .M .N .H .I .@ .O .E .L .J .K .R) # actual no-ops
    ),
    map({$_ => $unimplemented} qw(
        H D M I R L B X P S Q N C E A G K T
        CA CP CS DF DI DR EA ER EW FT IM IP LB LT
        PT RA RO RR SA SC SI SL SM SR TL UC WD WG XT YT
      ) # unimplemented ops
    ),
  );
  my @aliases = qw(
    PD PA
    PU PA
    PR PA
    AA AR
    H IN
    D PD
    M PU
    I PR
  );
  for (0..@aliases/2-1) {
    $camm2svg_commands{$aliases[2*$_]} = $camm2svg_commands{$aliases[2*$_+1]};
  }
  # maybe: !PG
}

#  <path d="%s" style='stroke:black; stroke-width: 40px; fill:#000000; fill-opacity:0.2;' />
our $svg_template = <<'EOSVG';
<?xml version="1.0" encoding="UTF-8"?>
<svg xmlns="http://www.w3.org/2000/svg" width="%f" height="%f">
<g transform='scale(0.025,-0.025) translate(%f,%f)'>
%s
</g>
</svg>
EOSVG

our $svg_path_template = <<'EOSVG';
  <path d="%s" style='stroke:%s; stroke-width: 40px; fill:#000000; fill-opacity:0.2;' />
EOSVG

sub to_svgpath {
  my ($self,$camm,$splittable) = @_;
  $self = $self->new unless ref $self;
  my %defcontext = (
    escape_char => "\003",
    p => [0,0],
    d => "",
  );
  $self->{$_} //= $defcontext{$_} for keys %defcontext;
  while ($camm ne "") {
    my ($cmd,$args) = _take_token(\$camm,$self->{escape_char});
    if (!defined $cmd) {
      $camm =~ s/^[^;\n]*[;\n]//;
      next;
    }
    my $handler = $camm2svg_commands{$cmd};
    if (defined $handler) {
      $handler->($self,$cmd,@$args) if $handler != 0;
      if ($splittable && !$self->{down}) {
        $self->{d} .= " M ".join(",",@{$self->{p}})." ";
      }
    } else {
      warn "ignoring unknown command \"$cmd\"";
    }
  }
  my $d = $self->{d};
  delete $self->{d};
  return $d;
}

# TODO: convert mm to pixels
sub to_svg {
  my ($self,$camm,$split,$colored) = @_;
  #$self = $self->new unless ref $self;
  $self = $self->new(output => sub {});
  my $d = $self->to_svgpath($camm,$split);
  my $win = $self->{input_window};
  my @origin = (0,0);
  my @size = (100,100);
  my $scale = 1/$units_per_mm;
  if (defined $win) {
    @origin = @$win[0,3];
    $_ = -$_ for @origin;
    @size = (($$win[2]-$$win[0])*$scale,($$win[3]-$$win[1])*$scale);
  }
  my $color = "black";
  my @paths;
  if ($split) {
    @paths = split /(?=M )/, $d;
    my $i = 0;
    for (@paths) {
      $color = sprintf "#%02x%02x%02x", map 127*(1+cos(($i/@paths*5/6-$_/3)*2*pi)),0..2
        if $colored;
      $_ = (sprintf $svg_path_template, $_, $color);
      $i++;
    }
  } else {
    @paths = (sprintf $svg_path_template, $d, $color);
  }
  return sprintf $svg_template, @size, @origin, join("",@paths);
}

1;