use v6-alpha;

class l33t-0.0.3;

=kwid

l33t interpreter

This isn't supposed to be particularly obfuscated code; but it is an
interpreter for the esoteric language l33t:

L<http://electrod.ifreepages.com/l33t.htm>

Which I think warrants its inclusion in this directory.

=cut

#our $MEMSIZE  = 64 * 1024;
our $MEMSIZE  = 200; # use this till pugs becomes faster. :-(
our $CELLSIZE = 256;
our $INSULT   = 'j00 4r3 teh 5ux0r';

has int8 @!mem;   # program and data memory space
has Int $.ip;     # instruction pointer
has Int $.mp;     # memory pointer
has Socket $con;  # "connection"; stdio when undef

has Bool $!trace;
has Bool $!debug;
has Bool $!step;
has Bool %!breakpoints;
has Str  $!last_db_command;
has Str  $!coninfo;

submethod BUILD {
   #say "BUILD";
   @!mem[$_] = 0 for 0 .. ($MEMSIZE-1);
   $.ip = 0;
   $.mp = 0;
   $!trace = $!step = $!debug;
   say "BUILD done" if $!debug;
}

submethod trace( Str $msg) {
    say $msg if $!trace;
}

method load($self: Str $program is copy) {
    self.trace("loading >>\n $program\n<<");
    $program ~~ s:P5/^\s*//;
    for split rx:P5/\s+/, $program -> $word {
        my $val = ([+] $word ~~ rx:P5:g/(\d)/) // 0;
        self.trace("word [$word] = $val");
        @!mem[$.mp++] = $val;
        $.mp %= $MEMSIZE;
    }
    $.mp++; $.mp %= $MEMSIZE;
    return $self;
}

submethod IIP() { # increment instruction pointer
    $.ip++;
    $.ip %= $MEMSIZE;
}

submethod DIP() { # decrement instruction pointer
    $.ip--;
    $.ip %= $MEMSIZE;
}

method run() {
    say "\nl33t d3bu993r - h1t 'h' 4 h31p / 'i' 4 inf0\n" if $!debug;
    #try {
      loop {
        self.debug if $!debug; # XXX: figure out how to bind this once
        given @!mem[$.ip] {
            when 0 { self.IIP };                                      # NOP
            when 1 { self.write; };                                   # WRT
            when 2 { self.read; };                                    # RD
            when 3 { self.bracket(3, 4) };                            # IF
            when 4 { self.bracket(4, 3) };                            # EIF
            when 5 { self.mem($.mp,        wrap=>$MEMSIZE) };         # FWD
            when 6 { self.mem($.mp,        wrap=>$MEMSIZE,  :down) }; # BAK
            when 7 { self.mem(@!mem[$.mp], wrap=>$CELLSIZE) };        # INC
            when 8 { self.mem(@!mem[$.mp], wrap=>$CELLSIZE, :down) }; # DEC
            when 9 { self.con };                                      # CON
            when 10 {                                              # END
                $.con.close if defined $.con;
                last;
            };

            # unknown opcode. this is NOT a (fatal) syntax error.
            say "$INSULT: wtf iz $_?";
            self.IIP;
        }
      }
    #CATCH "Debugger::QUIT" { say "qu1t" }
    #};
    #die $! if $!;
}

method con() {
    @!mem[$MEMSIZE .. $MEMSIZE+5] = @.mem[0 .. 5]; # ch33tz! 101
    my $ip = join ".", @!mem[$.mp .. $.mp+3];
    my $port = @!mem[$.mp+4] * 256 + @.mem[$.mp+5]; # >> f1x0rz v1m

    my $newcon = connect($ip, $port);
    if $newcon {
        $.con.close if $.con;
        $.con = $newcon;
        $!coninfo = "$ip:$port";
    }

    self.IIP;
    $.mp += 6;
    $.mp %= $MAXSIZE;
};

method mem($target is rw, :$wrap!, $down?) {
    self.IIP;
    $target += (@!mem[$.ip] + 1) * ($down ?? -1 !! 1);
    $target %= $wrap;
    self.IIP;
}

method bracket(: $own, $matching) {
    my $move     = (($own == 3) ?? {self.IIP} !! {self.DIP}); # mover in the right direction
    if (($own == 3 && @!mem[$.mp] == 0) || ($own == 4 && @.mem[$.mp] != 0)) {
        my $iflevel = 1;
        loop {
             $move();
             given @!mem[$.ip] {
                 when $own      { $iflevel++ };
                 when $matching { self.IIP, last unless --$iflevel };
             }
         }
    } else {
        self.IIP;
    }
}

method write() {
    print chr @!mem[$.mp];
    self.IIP;
}

method read() {
    @!mem[$.mp] = ord getc;
    self.IIP;
}

method demo(Class $class: ) {
    #say("demo starting");
    #$class.new.load(l33t::Samples.hello).run;
    $class.new(:debug).load($class.hello).run;
}

method debug() {
    repeat { self.debug_trace } until self.debug_interactive;
}

# true return == stay at this line
method debug_interactive() returns Bool {
    if %!breakpoints{$.ip} {
        say "<6r34k>";
    } elsif !$!step {
        return Bool::True;
    }
    repeat { print "$.ip> " } until (self.debug_action(=<>) || $!runnable);
    return $!runnable;
}


method debug_help {
    say qq:to/END/;
    h (help)   - print this message
    B          - list breakpoints
    b (break)  - toggle breakpoint here
    b ADDR     - toggle breakpoint at location ADDR
    C (clear)  - clear all breakpoints
    i (info)   - print misc. info (connection, etc.)
    ip ADDR    - change IP to ADDR
    ip +|-NUM  - move IP NUM positions back or forward
    l (list)   - list program (near context, starting here)
    l ADDR     - list program starting at ADDR
    mp ADDR    - change MP to ADDR
    mp +|-NUM  - move MP NUM positions back or forward
    q (quit)   - end program
    r (run)    - continue running until next breakpoint
    s (step)   - single step [enter to keep stepping]
    t (trace)  - toggle trace prints [currently {$!trace ?? "ON" !! "OFF"}]
    w PROG     - write program fragment PROG beginning at MP (changes MP)
    END
} # : f1x0rz v1m

method debug_action(Str $cmd is copy) returns Bool {
    $!runnable = False;
    $cmd ||= $!last_db_command;
    $!last_db_command = $cmd;
    given $cmd {
        when rx:P5/^\s*[Hh]|\?/ {        # h help
            self.debug_help;
        };
        #when 'B' { say %!breakpoints.keys.sort:{$^a<=>$^b} };
        when 'B' {
            say %!breakpoints.keys.join(" ");
        };
        when rx:P5/^\s*b\s*(\d+)?$/ {
            my $addr = $0 // $.ip;
            %!breakpoints{$addr} ^^= 1;
            %!breakpoints.delete($addr) unless %!breakpoints{$addr};
        };
        when 'C' {                          # C (clear)
            undefine %!breakpoints;
            say "6r34p01ntz (134r3";
        };
        when 'i' {
            say "(urr3nt (0nn3xxx10n: " ~ ($!coninfo // "stdio");
            say "tr4(3 m0de: " ~ ($!trace ?? "0n" !! "0ff");
            return Bool::True;
        };
        when rx:P5/^\s*[iI][pP]\s*(([-+])?\d+)/ {
            if $1 { $.ip += $0 }
            else  { $.ip  = $0 }
            $.ip %= $MEMSIZE;
            return Bool::True;
        };
        when rx:P5/^\s*[mM][pP]\s*(([-+])?\d+)/ {
            if $1 { $.mp += $0 }
            else  { $.mp  = $0 }
            $.mp %= $MEMSIZE;
            return Bool::True;
        };
        when rx:P5/^\s*r/ {              # r run
            $!step     = False;
            $!runnable = True;
        };
        when rx:P5/^\s*[lL]\s*(\d+)?/ {  # l list
            my $from = $0 // $.ip;
            @!mem[$MEMSIZE .. $MEMSIZE+63] = @.mem[0 .. 63]; # ch33tz! 101
            for 0 .. 3 -> $off {
                say "[{($from+$off*16)%$MEMSIZE}] " ~
                    @!mem[($from+$off*16) .. (($from+$off*16)+15)].join(" ");
            }
        };
        when 's' {                          # s step
            $!step     = True;
            $!runnable = True;
        };
        when 't' {                          # t trace
            $!trace ^^= 1;
        };
        when 'q' { die "Debugger::QUIT" };  # q quit
        when rx:P5/^\s*[wW]\s*(.+)/ {    # w write
            self.load($0);
            return True;
        };
        say "$INSULT: wft iz $_?";
        return True;
    }
    return False;
}

method debug_trace() {
    return unless $!trace;

    say("IP: $.ip => @!mem[$.ip]  MP: $.mp => @.mem[$.mp]");
    my $msg; # I want rvalue given.
    given @!mem[$.ip] {
        when 0 { $msg = "NOP" };
        when 1 { $msg = "WRT @!mem[$.mp]" };
        when 2 { $msg = "RD => $.mp [01d v4l = @!mem[$.mp]" };
        when 3 { $msg = "IF [{@!mem[$.mp] ?? 'tru3' !! 'f4l53'}]" };
        when 4 { $msg = "EIF [{@!mem[$.mp] ?? 'f4l53' !! 'tru3'}]" };
        when 5 {
            my $nmp = ($.mp + @!mem[($.ip+1) % $MEMSIZE] + 1) % $MEMSIZE;
            $msg = "FWD {@!mem[($.ip+1) % $MEMSIZE]} => $nmp [@.mem[$.mp]]" };
        when 6 {
            my $nmp = ($.mp - @!mem[($.ip+1) % $MEMSIZE] + 1) % $MEMSIZE;
            $msg = "BAK {@!mem[($.ip+1) % $MEMSIZE]} => $nmp [@.mem[$.mp]]" };
        when 7 {
            my $val = @!mem[($.ip+1) % $MEMSIZE];
            $msg = "INC $val => {(@!mem[$.mp]+$val+1) % $CELLSIZE}" };
        when 8 {
            my $val = @!mem[($.ip+1) % $MEMSIZE];
            $msg = "INC $val => {(@!mem[$.mp]-$val+1) % $CELLSIZE}" };
        when 9 {
            @!mem[$MEMSIZE .. $MEMSIZE+5] = @.mem[0 .. 5]; # ch33tz! 101
            my $ip = join ".", @!mem[$.mp .. $.mp+3];
            my $port = @!mem[$.mp+4] * 256 + @.mem[$.mp+5]; # >> f1x0rz v1m
            $msg = "CON $ip:$port"; # 41nt 1 t3h sw33t
        };
        when 10 { $msg = "END" };
        $msg = "$_ [unknown opcode]";
     };
     say $msg;
}

if !caller() { l33t.demo }

#class l33t::Samples-0.0.1;

method crazy_eights(Class $class :) {
    return q{
        7hink y0uR t0uGh?
        Ar3 y0U 5ure?
        5tEp uP 7hEn!!
        f3e11 t3h buRn!!
        7akE it!!!1
        y0u l1kE?
        We'LL PlAy CrAzY 8's bItCh!!!11
        I'll 0wN yOuR f4t A55!!!!
    };
}

method ascii_loop(Class $class :) {
    return q{
        ph34r my l3Et 5kIlLZ!!!!!!
        nErDs 41n't cool 3v3ry1!!!
        y0u b1g g33kS r teh g33kY sux0rs!
        PHE4R! LOLOLOLOLOLOL!!!
    };
}


# Sayeth the original source code:
# "Hello World" by Stephen McGreal.
# Note that the views expressed in this source code do not necessarily
# coincide with those of the author :o)
method hello(Class $class :) {
    return q{

    Gr34t l33tN3$$? 
    M3h...
    iT 41n't s0 7rIckY.

    l33t sP33k is U8er keWl 4nD eA5y wehn u 7hink 1t tHr0uGh.
    1f u w4nn4be UB3R-l33t u d3f1n1t3lY w4nt in 0n a b4d4sS h4xX0r1ng s1tE!!! ;p
    w4r3Z c0ll3cT10n2 r 7eh l3Et3r!

    Qu4k3 cL4nS r 7eh bE5t tH1ng 1n teh 3nTIr3 w0rlD!!!
    g4m3s wh3r3 u g3t to 5h00t ppl r 70tAl1_y w1cK1d!!
    I'M teh fr4GM4stEr aN I'lL t0t41_1Ly wIpE teh phr34k1ng fL00r ***j3d1 5tYlE*** wItH y0uR h1dE!!!! L0L0L0L!
    t3lEphR4gG1nG l4m3rs wit mY m8tes r34lLy k1kK$ A$$

    l33t hAxX0r$ CrE4t3 u8er- k3wL 5tUff lIkE n34t pR0gR4mm1nG lAnguidGe$...
    s0m3tIm3$ teh l4nGu4gES l00k jUst l1k3 rE41_ 0neS 7o mAkE ppl Th1nk th3y'r3 ju$t n0rMal lEE7 5pEEk but th3y're 5ecRetLy c0dE!!!!
    n080DY unDer5tAnD$ l33t SpEaK 4p4rT fr0m j3d1!!!!!
    50mE kId 0n A me$$4gEb04rD m1ghT 8E a r0xX0r1nG hAxX0r wH0 w4nT2 t0 bR34k 5tuFf, 0r mAyb3 ju5t sh0w 7eh wAy5 l33t ppl cAn 8E m0re lIkE y0d4!!! hE i5 teh u8ER!!!!
    1t m1ght 8E 5omE v1rus 0r a Pl4ySt4tI0n ch34t c0dE.
    1t 3v3n MiTe jUs7 s4y "H3LL0 W0RLD!!!" u ju5t cAn'T gu3s5.
    tH3r3's n3v3r anY p0iNt l00KiNg sC3pT1c4l c0s th4t, be1_1Ev3 iT 0r n0t, 1s whAt th1s 1s!!!!!

    5uxX0r5!!!L0L0L0L0L!!!!!!!
    };
}