nott

#!/usr/bin/env perl

# nott - An unofficial terminal-based NOS Teletekst browser
# Copyright (C) 2020  Chris Smeele
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <https://www.gnu.org/licenses/>.

# The big thing that makes this different from other existing NOS TT browsers
# (including the web-based one) is that we parse actual teletext data (i.e. all
# the glorious stuff like control characters), instead of using the buggy
# JSON/HTML API that other clients use.

# Likely you will want to have a font in your terminal that can render Teletext
# mosaic characters. I strongly recommend getting the amazing and free unscii
# raster font by Viznut:
#
#  http://pelulamu.net/unscii/
#
# nott outputs mosaic characters in the U+e080-U+e0bf range, as mapped by unscii.
# There is also a relatively new unicode range for Teletext characters
# (starting U+1fb00), but this doesn't render well in my terminal, so I ignore it.
#
# In the future, I might modify this to be able to use sixels instead of
# depending on good unicode&font support. But well... my current terminal
# doesn't support sixels yet :-)

# usage: nott                        → interactive mode
#        nott <pagenr> [subpagenr]   → render one page
#
# See the bottom of this file for interactive-mode keybindings.
#
# keybindings can be customized by creating an *executable* rc file in one of
# the following locations (in descending order of precedence):
#
# - $HOME/.nottrc
# - $XDG_CONFIG_HOME/nottrc (or ~/.config/nottrc)
# - <directory of this file>/nottrc
#
# By default, if you downloaded nott in an archive or via git, you'll already
# have a nottrc file next to this script. You can use that as a reference for
# how to add/modify keybindings.

# TODO 404 should be non-fatal

use v5.20;
use warnings;
use autodie;
use Carp;
use utf8;
use open qw( :encoding(UTF-8) :std );
use LWP::UserAgent;
#use Data::Dump;
use FindBin;

binmode STDOUT, ':encoding(UTF-8)';

sub foldl(&@) {
    my ($c, $v, @l) = @_;
    for (@l) {
        local $a = $v;
        local $b = $_;
        $v = $c->();
    }
    $v
}

sub min { foldl { $a < $b ? $a : $b } @_ }
sub max { foldl { $a < $b ? $b : $a } @_ }

sub zip {
    my @acc;
    for my $i (0..(min map $#$_, @_)) {
        push @acc, [map $_->[$i], @_];
    }
    @acc
}

use feature qw(signatures);
no warnings qw(experimental::signatures);

my $uas = 'Sowieso de officiële teletekst-client/1.0';
my $ua = LWP::UserAgent->new(agent => $uas, timeout => 10);

sub slurp { open(my $fh, '<', shift) or croak "$!"; <$fh> }

#sub get { slurp("/tmp/data") }
sub get { my $r = $ua->get(shift);
          $r->is_success or croak $r->status_line;
          $r->decoded_content }

sub get_tt($page = 100, $subpage = 1) {
    my $data = get sprintf('%s%d-%d',
                           'https://teletekst-data.nos.nl/page/',
                           $page, $subpage);

    my @cnav = $data =~ m@(?<=^ftl=)\d+-\d+$@gm;
    my %nav  = $data =~ m@(?<=^pn=)([pn][s_])(\d+-\d+)$@gm;

    $data =~ m@(?<=^<pre>).*(?=</pre>)@gm or croak "no body";
    my $body = $&;

    croak "weird body" if length $body != 1000;

    return {body => $body, cnav => [@cnav], nav => {%nav},
            page => $page, subpage => $subpage};
}

# Control characters {{{

my %C1 = map(($_->[0], chr $_->[1]),
         zip [qw/ ABK ANR ANG ANY ANB ANM ANC ANW
                  FSH STD EBX SBX NSZ DBH DBW DBS
                  MBK MSR MSG MSY MSB MSM MSC MSW
                  CDY SPL STL ESC BBD NBD HMS RMS /],
             [0x00 .. 0x1f]);

# }}}
# Map mosaic dots for translation to unicode {{{

# input: a 6-bit number, 1 bit per sextant dot.
#        dots are counted left to right, line by line.
#        (MSB is bottom-right)
#        0 1
#        2 3
#        4 5
#
# output: a N-bit number, representing an offset into a
#         certain unicode block.

sub to_unscii_pua($c) {
    # 0 3
    # 1 4
    # 2 5
    my @b = (map !!($c & (1<<$_)), 0..5)
            [0,2,4,1,3,5]; # transpose
    foldl { $a | ($b[$b]<<$b) } 0, 0..$#b;
}

sub to_braille($c) {
    # 0 3
    # 1 4
    # 2 5
    # 6 7 (yep)
    my @b = (map !!($c & (1<<$_)), 0..5)
            [0,2,2,1,3,3,4,5];
    foldl { $a | ($b[$b]<<$b) } 0, 0..$#b;
}

# }}}
# Mosaic character mappings {{{

our %M = (
    sextants => # {{{
        # unicode sextant block drawing characters.
        # this is relatively new, so it may not work with your fonts.
        [('?') x 0x20 #     0x00
        ,' '          #     0x20
        ,map(chr,     #     0x21
             0x1fb00 .. 0x1fb13),
        ,chr(0x258c)  #     0x35  (left half)
        ,map(chr,     #     0x36
             0x1fb14 .. 0x1fb1d),
        ,'@'          #     0x40
        ,'A'..'Z'     #
        ,chr(0x2190)  # ←   0x5b
        ,chr(0x00bd)  # ½
        ,chr(0x2192)  # →
        ,chr(0x2191)  # ↑
        ,chr(0x005f)  # _
        ,map(chr,     #     0x60
             0x1fb1e .. 0x1fb27),
        ,chr(0x2590)  #     0x6a  (right half)
        ,map(chr,     #     0x6b
             0x1fb28 .. 0x1fb3b),
        ,chr(0x2588)] #     0x7f  (full block) }}}
   ,braille => # {{{
        # unicode braille
        # braille has 8 dots instead of six.
        # close enough.
        [('?') x 0x20 #     0x00
        ,(map chr(0x2800+to_braille($_)),
              0x00 .. 0x1f)
        ,'@'          #     0x40
        ,'A'..'Z'     #
        ,chr(0x2190)  # ←   0x5b
        ,chr(0x00bd)  # ½
        ,chr(0x2192)  # →
        ,chr(0x2191)  # ↑
        ,chr(0x005f)  # _
        ,(map chr(0x2800+to_braille($_)),
              0x20 .. 0x3f)] # }}}
   ,unscii_pua => # {{{
        # needed only for unscii < 2.0. newer font versions have these
        # characters mapped according to unicode v13, allowing use of the
        # 'sextants' mapping above.
        [('?') x 0x20 #     0x00
        ,(map chr(0xe080+to_unscii_pua($_)),
              0x00 .. 0x1f)
        ,'@'          #     0x40
        ,'A'..'Z'     #
        ,chr(0x2190)  # ←   0x5b
        ,chr(0x00bd)  # ½
        ,chr(0x2192)  # →
        ,chr(0x2191)  # ↑
        ,chr(0x005f)  # _
        ,(map chr(0xe080+to_unscii_pua($_)),
              0x20 .. 0x3f)] # }}}
   ,fallback => # {{{
        # as a 'fallback', do not attempt to draw special
        # characters at all.
        [('?') x 0x20 #     0x00
        ,(' ') x 0x20
        ,'@'          #     0x40
        ,'A'..'Z'     #
        ,(' ') x 5
        ,(' ') x 0x1f
        ,'#'] # }}}
);

our @M = @{$M{sextants}};

# use this to figure out how your font renders each
# character mapping:
#
#say "num | braille | sextants | unscii_pua";
#say join " | ", @$_
#    for zip [map sprintf("%02x", $_), 0..127],
#            $M{braille},
#            $M{sextants},
#            $M{unscii_pua};
#exit;

# }}}

#              ABK ANR ANG ANY ANB ANM ANC ANW
my @COLFG = qw(  0 196  46 226  21 201  51  15);
my @COLBG = qw(  0 196  46 226  21 201  51  15);

sub colorfg  { "\e[38;5;$COLFG[$_[0]]m" }
sub colorbg  { "\e[48;5;$COLBG[$_[0]]m" }
sub colorclr { "\e[0m" }

sub eval_tt($data) {
    local $_ = $data;

    my %st;

    my $out;
    my $i = 0;

    for (split //) {

        if ($i % 40 == 0) {
            %st = (fg => 7, bg => 0, mosaic => 0);
            $out .= colorbg(0) . " " . colorclr . "\n" if $i;
            $out .= colorbg($st{bg}) . colorfg($st{fg});
        }
        ++$i;

        if ($_ ge ' ') {
            if ($st{mosaic}) {
                $out .= ord($_) < @M ? $M[ord $_] : '?';
            } else {
                $out .= $_ eq chr(0x7f) ? '█' : $_;
            }
        } else {
            if ($_ ge $C1{ABK} && $_ le $C1{ANW}) {
                $st{fg} = ord($_) - ord($C1{ABK});
                $st{mosaic} = 0;

                $out .= colorfg $st{fg};

            } elsif ($_ ge $C1{MBK} && $_ le $C1{MSW}) {
                $st{fg} = ord($_) - ord($C1{MBK});
                $st{mosaic} = 1;

                $out .= colorfg $st{fg};

            } elsif ($_ eq $C1{BBD}) {
                $st{bg} = 0;
                $out .= colorbg $st{bg};

            } elsif ($_ eq $C1{NBD}) {
                $st{bg} = $st{fg};
                $out .= colorbg $st{bg};

            } elsif ($_ eq $C1{DBH}) { # Doubled char sizes not supported.
            } elsif ($_ eq $C1{DBW}) {
            } elsif ($_ eq $C1{DBS}) {
            } elsif ($_ eq $C1{NSZ}) {
            } else {
                #printf STDERR "?<%02x>", ord $_;
            }
            $out .= ' ';
        }
    }

    $out .= colorbg(0) . " " . colorclr . "\n";
    $out
}

if (@ARGV) {
    print eval_tt get_tt(@ARGV)->{body};
    exit;
}

# ----------------------------------------------------------------------
# interactive mode

my $LINES = 25+2;
my $COLS  = 40;

my $tt;
my @hist;
my $histi = -1;

sub print_nav {
    print  colorbg(0) . colorfg(7);
    printf "%s\n « %5s ← %5s  %5s  %5s → %5s » ",
           " "x($COLS+1),
           $tt->{nav}->{p_} // "",
           $tt->{nav}->{ps} // "",
           $tt->{page}."-".$tt->{subpage},
           $tt->{nav}->{ns} // "",
           $tt->{nav}->{n_} // "";
    print  colorclr;
}

sub go($page=100, $subpage=1) {
    my $fst = not defined $tt;

    $tt = get_tt($page, $subpage);

    print "\r\e[${LINES}A" unless $fst;
    print eval_tt $tt->{body};

    if ($histi < $#hist) {
        if ($hist[$histi+1][0] != $page
         or $hist[$histi+1][1] != $subpage) {
            splice @hist, $histi+1;
            push @hist, [$page, $subpage];
            $histi++;
        } else {
            $histi++;
        }
    } else {
        push @hist, [$page, $subpage];
        $histi++;
    }

    print_nav;
}

sub back {
    if ($histi > 0) {
        # Kinda wonky but hey it works.
        $histi -= 2;
        go $hist[$histi+1]->[0], $hist[$histi+1]->[1];
    }
}
sub forward {
    if ($histi < $#hist) {
        go $hist[$histi+1]->[0], $hist[$histi+1]->[1];
    }
}

sub pnext { go $tt->{nav}->{n_} =~ m/(\d+)-(\d+)/ if exists $tt->{nav}->{n_} }
sub pprev { go $tt->{nav}->{p_} =~ m/(\d+)-(\d+)/ if exists $tt->{nav}->{p_} }
sub snext { go $tt->{nav}->{ns} =~ m/(\d+)-(\d+)/ if exists $tt->{nav}->{ns} }
sub sprev { go $tt->{nav}->{ps} =~ m/(\d+)-(\d+)/ if exists $tt->{nav}->{ps} }

# go to one of the four colored navigation destinations.
sub cnav($i = 0) { $i < 4 and go $tt->{cnav}->[$i] =~ m/(\d+)-(\d+)/ }

use Term::ReadKey;

sub ctl { $_[0] eq '?' ? "\x7f" : chr(ord(uc $_[0])-ord('A')+1) }

# Try to find a keybindings file.
our %keys;
for ("$ENV{HOME}/.nottrc",
     ($ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config") . "/nottrc",
     $FindBin::RealBin . "/nottrc") {

     next unless -x;
     do $_;
     $@ and die "could not evaluate nottrc at '$_': $@";
     last
}

print "\e[2J\e[1;1H";
go(100);

$| = 1;
ReadMode 3;

sub clean_exit { ReadMode 0; print "\e[2J\e[1;1H"; exit 0 }

  $SIG{TERM}
= $SIG{INT}
= $SIG{HUP}
= sub { clean_exit };

my $inp = "";
while (1) {
    print "\e[19G";
    if (length $inp) {
        printf "%-3d  \e[%dD", $inp, 5-length $inp;
    } else {
        print "$tt->{page}-$tt->{subpage}";
        print "\e[5D";
    }
    for (ReadKey 0) {
        clean_exit unless defined $_;
        clean_exit if $_ eq ctl('C')
                   or $_ eq ctl('D')
                   or $_ eq ctl('[');

        if (exists $keys{$_}) {
            # evaluate nottrc keybinding.

            # `$keys{...} = undef` removes a default keybinding.
            next unless defined $keys{$_};

            my $r = ref $keys{$_};
            if ($r eq 'CODE') {
                $keys{$_}->()
            } elsif (not $r) {
                go $keys{$_}
            } else {
                die sprintf "Unexpected %s in %%keys for key \\x%02x\n", $r, ord($_);
            }
        } elsif ($_ eq ctl('H') or $_ eq ctl('?')) {
            $inp = substr $inp, 0, -1 if length $inp;
        } elsif ($_ ge '0' and $_ le '9') {
            $inp .= $_;
            if (length($inp) == 3) {
                go $inp;
                $inp = '';
            }

            # Default keybindings follow. These are only
            # used if no 'nottrc' file could be executed,
            # or if these keys are not overridden by the
            # nottrc file.

        } elsif ($_ eq 'q') { clean_exit;
        } elsif ($_ eq ctl('O')             ) { back
        } elsif ($_ eq ctl('I')             ) { forward
        } elsif ($_ eq ctl('N') or $_ eq 'j') { pnext
        } elsif ($_ eq ctl('P') or $_ eq 'k') { pprev
        } elsif ($_ eq ctl('F') or $_ eq 'l') { snext
        } elsif ($_ eq ctl('B') or $_ eq 'h') { sprev
        } elsif ($_ eq '!') { cnav 0
        } elsif ($_ eq '@') { cnav 1
        } elsif ($_ eq '#') { cnav 2
        } elsif ($_ eq '$') { cnav 3
        } elsif ($_ eq 'H') { go 100
        } elsif ($_ eq 'W') { go 702
        } elsif ($_ eq 'N') { go 101
        } elsif ($_ eq 'F') { go 520
        } elsif ($_ eq 'P') { go 201
        } elsif ($_ eq 'O') { go 401
        }
    }
}