#!/usr/bin/perl

$/ = "";

$name = @ARGV ? $ARGV[0] : "something";
$name =~ s/\..*//;

print <<"END";
.rn '' }`
''' \$RCSfile\$\$Revision\$\$Date\$
''' 
''' \$Log\$
''' 
.de Sh
.br
.if t .Sp
.ne 5
.PP
\\fB\\\\\$1\\fR
.PP
..
.de Sp
.if t .sp .5v
.if n .sp
..
.de Ip
.br
.ie \\\\n(.\$>=3 .ne \\\\\$3
.el .ne 3
.IP "\\\\\$1" \\\\\$2
..
.de Vb
.ft C
.nf
.ne \\\\\$1
..
.de Ve
.ft R

.fi
..
'''
'''
'''     Set up \\*(-- to give an unbreakable dash;
'''     string Tr holds user defined translation string.
'''     Bell System Logo is used as a dummy character.
'''
.tr \\(*W-|\\(bv\\*(Tr
.ie n \\{\\
.ds -- \\(*W-
.if (\\n(.H=4u)&(1m=24u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-12u'-\\" diablo 10 pitch
.if (\\n(.H=4u)&(1m=20u) .ds -- \\(*W\\h'-12u'\\(*W\\h'-8u'-\\" diablo 12 pitch
.ds L" ""
.ds R" ""
.ds L' '
.ds R' '
'br\\}
.el\\{\\
.ds -- \\(em\\|
.tr \\*(Tr
.ds L" ``
.ds R" ''
.ds L' `
.ds R' '
.if t .ds PI \\(*p
.if n .ds PI PI
'br\\}
.TH \U$name\E 1 "\\*(RP"
.UC
END

print <<'END';
.if n .hy 0 
.if n .na
.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p'
.de CQ          \" put $1 in typewriter font
'.ft C
'if n "\c
'if t \\\\&\\\\$1\c
'if n \\\\&\\\\$1\c
'if n \&"
\\\\&\\\\$2 \\\\$3 \\\\$4 \\\\$5 \\\\$6 \\\\$7
'.ft R
..
END

$indent = 0;

while (<>) {
    chomp;

    # Translate verbatim paragraph

    if (/^\s/) {
	@lines = split(/\n/);
	for (@lines) {
	    1 while s
		{^( [^\t]* ) \t ( \t* ) }
		{ $1 . ' ' x (8 - (length($1)%8) + 8 * (length($2))) }ex;
	    s/\\/\\e/g;
	    s/\A/\\&/s;
	}
	$lines = @lines;
	makespace() unless $verbatim++;
	print ".Vb $lines\n";
	print join("\n", @lines), "\n";
	print ".Ve\n";
	$needspace = 0;
	next;
    }

    $verbatim = 0;

    # check for things that'll hosed our noremap scheme; affects $_
    init_noremap();

    if (!/^=item/) {

	# trofficate backslashes; must do it before what happens below
	s/\\/noremap('\\e')/ge;

	# first hide the escapes in case we need to 
	# intuit something and get it wrong due to fmting

	s/([A-Z]<[^<>]*>)/noremap($1)/ge;

	# func() is a reference to a perl function
	s{
	    \b
	    (
		[:\w]+ \(\)
	    )
	} {I<$1>}gx;

	# func(n) is a reference to a man page
	s{
	    (\w+)
	    (
		\(
		    [^\s,\051]+
		\)
	    )
	} {I<$1>\\|$2}gx;

	# convert simple variable references
	s/([\$\@%][\w:]+)/C<$1>/g;

	if (m{ (
		    [\-\w]+
		    \(
			[^\051]*?
			[\@\$,]
			[^\051]*?
		    \)
		)
	    }x && $` !~ /([LCI]<[^<>]*|-)$/ && !/^=\w/) 
	{
	    warn "``$1'' should be a [LCI]<$1> ref";
	} 

	while (/(-[a-zA-Z])\b/g && $` !~ /[\w\-]$/) {
	    warn "``$1'' should be [CB]<$1> ref";
	} 

	# put it back so we get the <> processed again;
	clear_noremap(0); # 0 means leave the E's

    } else {
	# trofficate backslashes
	s/\\/noremap('\\e')/ge;

    } 

    # need to hide E<> first; they're processed in clear_noremap
    s/(E<[^<>]+>)/noremap($1)/ge;


    $maxnest = 10;
    while ($maxnest-- && /[A-Z]</) {

	# can't do C font here
	s/([BI])<([^<>]*)>/font($1) . $2 . font('R')/eg;

	# files and filelike refs in italics
	s/F<([^<>]*)>/I<$1>/g;

	# no break -- usually we want C<> for this
	s/S<([^<>]*)>/nobreak($1)/eg;

	# LREF: a manpage(3f) 
	s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the I<$1>$2 manpage:g;

	# LREF: an =item on a manpage
	s{
	    L<
		([^/]+)
		/
		(
		    [:\w]+
		    (\(\))?
		)
	    >
	} {the C<$2> entry in the I<$1> manpage}gx;

	# LREF: a =head2 (head1?), maybe on a manpage, maybe right here
	# the "func" can disambiguate
	s{
	    L<
		(?:
		    ([a-zA-Z]\S+?) / 
		)?
		"?(.*?)"?
	    >
	}{
	    do {
		$1 	# if no $1, assume it means on this page.
		    ?  "the section on I<$2> in the I<$1> manpage"
		    :  "the section on I<$2>"
	    } 
	}gex;

	s/Z<>/\\&/g;

	# comes last because not subject to reprocessing
	s/C<([^<>]*)>/noremap("\\fC${1}\\fR")/eg;
    }

    if (s/^=//) {
	$needspace = 0;		# Assume this.

	s/\n/ /g;

	($Cmd, $_) = split(' ', $_, 2);

	if (defined $_) {
	    s/"/""/g;
	    &escapes;
	}

	clear_noremap(1);

	if ($Cmd eq 'head1') {
	    print qq{.SH "$_"\n}
	}
	elsif ($Cmd eq 'head2') {
	    print qq{.Sh "$_"\n}
	}
	elsif ($Cmd eq 'over') {
	    push(@indent,$indent);
	    $indent = $_ + 0;
	}
	elsif ($Cmd eq 'back') {
	    $indent = pop(@indent);
	    warn "Unmatched =back\n" unless defined $indent;
	    $needspace = 1;
	}
	elsif ($Cmd eq 'item') {
	    s/^\* /\\(bu /g;
	    print STDOUT qq{.Ip "$_" $indent\n};
	}
	else {
	    warn "Unrecognized directive: $Cmd\n";
	}
    }
    else {
	if ($needspace) {
	    &makespace;
	}
	&escapes;
	clear_noremap(1);
	print;
	$needspace = 1;
    }
}

print <<"END";

.rn }` ''
END

#########################################################################

sub nobreak {
    my $string = shift;
    $string =~ s/ /\\ /g;
    $string;
}

sub escapes {

    # translate the minus in foo-bar into foo\-bar for roff
    s/([^0-9a-z-])-([^-])/$1\\-$2/g;

    # fix up quotes; this is someone tricky
    if (!/""/) {
	s/(^|\s)(['"])/noremap("$1\\*(L$2")/ge;
	s/(['"])($|[\-\s,;\\!?.])/noremap("\\*(R$1$2")/ge;
    }

    # make -- into the string version \*(-- (defined above)
    s/\b--\b/\\*(--/g;
    s/"--\b/\\*(--/g;  # should be a better way
    s/\b--"/\\*(--/g;

    # make sure that func() keeps a bit a space tween the parens
    s/\b\(\)/(\\|)/g;

    # make C++ into \*C+, which is a squinched version (defined above)
    s/\bC\+\+/\\*(C+/g;

    # make double underbars have a little tiny space between them
    s/__/_\\|_/g;

    # PI goes to \*(-- (defined above)
    s/\bPI\b/noremap('\\*(PI')/ge;

    # make all caps a teeny bit smaller, but don't muck with embedded code literals
    my $hidcfont = font('C');
    if ($Cmd !~ /^head1/) { # SH already makes smaller
	# /g isn't enough; 1 while or we'll be off
	1 while s{
	    (?!$hidcfont)(..|^.|^)
	    \b
	    (
		[A-Z][\/A-Z+:\-\d_$.]+
	    )
	    (s?) 		
	    \b
	} {$1\\s-1$2\\s0}gmox;
    }
}

# make troff just be normal, but make small nroff get quoted
# decided to just put the quotes in the text; sigh;
sub ccvt {
     local($_,$prev) = @_;
     if ( /^\W+$/ && !/^\$./ ) {
 	($prev && "\n") . noremap(qq{.CQ $_ \n\\&});
 	# what about $" ?
     } else {
 	noremap(qq{\\fC$_\\fR});
     } 
    noremap(qq{.CQ "$_" \n\\&});
} 

sub makespace {
    if ($indent) {
	print ".Sp\n";
    }
    else {
	print ".PP\n";
    }
}

sub font {
    local($font) = shift;
    return '\\f' . noremap($font);
} 

sub noremap {
    local($thing_to_hide) = shift;
    $thing_to_hide =~ tr/\000-\177/\200-\377/;
    return $thing_to_hide;
} 

sub init_noremap {
    if ( /[\200-\377]/ ) {
	warn "hit bit char in input stream";
    } 
} 

sub clear_noremap {
    my $ready_to_print = $_[0];

    tr/\200-\377/\000-\177/;

    # trofficate backslashes
    # s/(?!\\e)(?:..|^.|^)\\/\\e/g;

    # now for the E<>s, which have been hidden until now
    # otherwise the interative \w<> processing would have
    # been hosed by the E<gt>
    s {
	    E<	
	    ( [A-Za-z]+ )	
	    >	
    } { 
	 do {	
	     exists $HTML_Escapes{$1}
		? do { $HTML_Escapes{$1} }
		: do {
		    warn "Unknown escape: $& in $_";
		    "E<$1>";
		} 
	 } 
    }egx if $ready_to_print;
} 

BEGIN {
%HTML_Escapes = (
    'amp'	=>	'&',	#   ampersand
    'lt'	=>	'<',	#   left chevron, less-than
    'gt'	=>	'>',	#   right chevron, greater-than
    'quot'	=>	'"',	#   double quote

    # could theoretically handle a few these using the ms.acc accents
    #
##    "Aacute"	=>	'?',	#   capital A, acute accent
##    "aacute"	=>	'?',	#   small a, acute accent
##    "Acirc"	=>	'?',	#   capital A, circumflex accent
##    "acirc"	=>	'?',	#   small a, circumflex accent
##    "AElig"	=>	'?',	#   capital AE diphthong (ligature)
##    "aelig"	=>	'?',	#   small ae diphthong (ligature)
##    "Agrave"	=>	'?',	#   capital A, grave accent
##    "agrave"	=>	'?',	#   small a, grave accent
##    "Aring"	=>	'?',	#   capital A, ring
##    "aring"	=>	'?',	#   small a, ring
##    "Atilde"	=>	'?',	#   capital A, tilde
##    "atilde"	=>	'?',	#   small a, tilde
##    "Auml"	=>	'?',	#   capital A, dieresis or umlaut mark
##    "auml"	=>	'?',	#   small a, dieresis or umlaut mark
##    "Ccedil"	=>	'?',	#   capital C, cedilla
##    "ccedil"	=>	'?',	#   small c, cedilla
##    "Eacute"	=>	'?',	#   capital E, acute accent
##    "eacute"	=>	'?',	#   small e, acute accent
##    "Ecirc"	=>	'?',	#   capital E, circumflex accent
##    "ecirc"	=>	'?',	#   small e, circumflex accent
##    "Egrave"	=>	'?',	#   capital E, grave accent
##    "egrave"	=>	'?',	#   small e, grave accent
##    "ETH"	=>	'?',	#   capital Eth, Icelandic
##    "eth"	=>	'?',	#   small eth, Icelandic
##    "Euml"	=>	'?',	#   capital E, dieresis or umlaut mark
##    "euml"	=>	'?',	#   small e, dieresis or umlaut mark
##    "Iacute"	=>	'?',	#   capital I, acute accent
##    "iacute"	=>	'?',	#   small i, acute accent
##    "Icirc"	=>	'?',	#   capital I, circumflex accent
##    "icirc"	=>	'?',	#   small i, circumflex accent
##    "Igrave"	=>	'?',	#   capital I, grave accent
##    "igrave"	=>	'?',	#   small i, grave accent
##    "Iuml"	=>	'?',	#   capital I, dieresis or umlaut mark
##    "iuml"	=>	'?',	#   small i, dieresis or umlaut mark
##    "Ntilde"	=>	'?',	#   capital N, tilde
##    "ntilde"	=>	'?',	#   small n, tilde
##    "Oacute"	=>	'?',	#   capital O, acute accent
##    "oacute"	=>	'?',	#   small o, acute accent
##    "Ocirc"	=>	'?',	#   capital O, circumflex accent
##    "ocirc"	=>	'?',	#   small o, circumflex accent
##    "Ograve"	=>	'?',	#   capital O, grave accent
##    "ograve"	=>	'?',	#   small o, grave accent
##    "Oslash"	=>	'?',	#   capital O, slash
##    "oslash"	=>	'?',	#   small o, slash
##    "Otilde"	=>	'?',	#   capital O, tilde
##    "otilde"	=>	'?',	#   small o, tilde
##    "Ouml"	=>	'?',	#   capital O, dieresis or umlaut mark
##    "ouml"	=>	'?',	#   small o, dieresis or umlaut mark
##    "szlig"	=>	'?',	#   small sharp s, German (sz ligature)
##    "THORN"	=>	'?',	#   capital THORN, Icelandic
##    "thorn"	=>	'?',	#   small thorn, Icelandic
##    "Uacute"	=>	'?',	#   capital U, acute accent
##    "uacute"	=>	'?',	#   small u, acute accent
##    "Ucirc"	=>	'?',	#   capital U, circumflex accent
##    "ucirc"	=>	'?',	#   small u, circumflex accent
##    "Ugrave"	=>	'?',	#   capital U, grave accent
##    "ugrave"	=>	'?',	#   small u, grave accent
##    "Uuml"	=>	'?',	#   capital U, dieresis or umlaut mark
##    "uuml"	=>	'?',	#   small u, dieresis or umlaut mark
##    "Yacute"	=>	'?',	#   capital Y, acute accent
##    "yacute"	=>	'?',	#   small y, acute accent
##    "yuml"	=>	'?',	#   small y, dieresis or umlaut mark
);
}