% helpwin.red
%
% interfacing reduce help file to Microsoft help compiler rtf structure
%
% Author: Herbert Melenk, ZIB Berlin
%
% November 1992
%
fluid '(outc newl par !*font !*newline !*windows);
!*windows:=t;
helvetica:= "f2";
courier:= "f4";
% The original version of this file had initoutput() as an empty
% procedure, but after the run it used shell commands to concatenate
% the following text at the start and end of the generated file. To
% reduce the amount of shell programming needed and keep as much as
% possible in REDUCE code the (fixed) header and trailer text is
% generated explicitly (albeit clumsily) here now.
symbolic procedure initoutput ();
begin
scalar o;
o := wrs outfile!*;
prin2t "{\rtf1\ansi \deff0{\fonttbl{\f0\froman Tms Rmn;}";
prin2t "{\f1\fdecor Symbol;}";
prin2t "{\f2\fswiss Helv;}";
prin2t "{\f3\fmodern pica;}";
prin2t "{\f4\fmodern Courier;}";
prin2t "{\f5\fmodern elite;}";
prin2t "{\f6\fmodern prestige;}";
prin2t "{\f7\fmodern lettergothic;}";
prin2t "{\f8\fmodern gothicPS;}";
prin2t "{\f9\fmodern cubicPS;}";
prin2t "{\f10\fmodern lineprinter;}";
prin2t "{\f11\fswiss Helvetica;}";
prin2t "{\f12\fmodern avantegarde;}";
prin2t "{\f13\fmodern spartan;}";
prin2t "{\f14\fmodern metro;}";
prin2t "{\f15\fmodern presentation;}";
prin2t "{\f16\fmodern APL;}";
prin2t "{\f17\fmodern OCRA;}";
prin2t "{\f18\fmodern OCRB;}";
prin2t "{\f19\froman boldPS;}";
prin2t "{\f20\froman emperorPS;}";
prin2t "{\f21\froman madaleine;}";
prin2t "{\f22\froman zapf humanist;}";
prin2t "{\f23\froman classic;}";
prin2t "{\f24\froman roman f;}";
prin2t "{\f25\froman roman g;}";
prin2t "{\f26\froman roman h;}";
prin2t "{\f27\froman timesroman;}";
prin2t "{\f28\froman century;}";
prin2t "{\f29\froman palantino;}";
prin2t "{\f30\froman souvenir;}";
prin2t "{\f31\froman garamond;}";
prin2t "{\f32\froman caledonia;}";
prin2t "{\f33\froman bodini;}";
prin2t "{\f34\froman university;}";
prin2t "{\f35\fscript Script;}";
prin2t "{\f36\fscript scriptPS;}";
prin2t "{\f37\fscript script c;}";
prin2t "{\f38\fscript script d;}";
prin2t "{\f39\fscript commercial script;}";
prin2t "{\f40\fscript park avenue;}";
prin2t "{\f41\fscript coronet;}";
prin2t "{\f42\fscript script h;}";
prin2t "{\f43\fscript greek;}";
prin2t "{\f44\froman kana;}";
prin2t "{\f45\froman hebrew;}";
prin2t "{\f46\froman roman s;}";
prin2t "{\f47\froman russian;}";
prin2t "{\f48\froman roman u;}";
prin2t "{\f49\froman roman v;}";
prin2t "{\f50\froman roman w;}";
prin2t "{\f51\fdecor narrator;}";
prin2t "{\f52\fdecor emphasis;}";
prin2t "{\f53\fdecor zapf chancery;}";
prin2t "{\f54\fdecor decor d;}";
prin2t "{\f55\fdecor old english;}";
prin2t "{\f56\fdecor decor f;}";
prin2t "{\f57\fdecor decor g;}";
prin2t "{\f58\fdecor cooper black;}";
prin2t "{\f59\fnil linedraw;}";
prin2t "{\f60\fnil math7;}";
prin2t "{\f61\fnil math8;}";
prin2t "{\f62\fnil bar3of9;}";
prin2t "{\f63\fnil EAN;}";
prin2t "{\f64\fnil pcline;}";
prin2t "{\f65\fnil tech h;}";
prin2t "{\f66\fswiss Helvetica-Narrow;}";
prin2t "{\f67\fmodern Modern;}";
prin2t "{\f68\froman Roman;}}";
terpri();
princ "{\colortbl;\red0\green0\blue0;\red0\green0\blue255;";
prin2t "\red0\green255\blue255;\red0\green255\blue0;";
princ "\red255\green0\blue255;\red255\green0\blue0;";
prin2t "\red255\green255\blue0;\red255\green255\blue255;}";
princ "{\stylesheet{\s244 \fs16\up6 \sbasedon0\snext0";
prin2t " footnote reference;}";
prin2t "{\s245 \fs20 \sbasedon0\snext245 footnote text;}";
prin2t "{\s246\li720 \i\fs20 ";
prin2t "\sbasedon0\snext255 heading 9;}";
prin2t "{\s247\li720 \i\fs20 \sbasedon0\snext255 heading 8;}";
prin2t "{\s248\li720 \i\fs20 \sbasedon0\snext255 heading 7;}";
prin2t "{\s249\li720 \fs20\ul \sbasedon0\snext255 heading 6;}";
prin2t "{\s250\li720 \b\fs20 \sbasedon0\snext255 heading 5;}";
prin2t "{\s251\li360 ";
prin2t "\ul \sbasedon0\snext255 heading 4;}";
prin2t "{\s252\li360 \b \sbasedon0\snext255 heading 3;}";
prin2t "{\s253\sb120 \b\f2 \sbasedon0\snext0 heading 2;}";
prin2t "{\s254\sb240 \b\f2\ul \sbasedon0\snext0 heading 1;}";
prin2t "{\s255\li720 \fs20 \sbasedon0\snext255 Normal Indent;}";
prin2t "{\fs20 ";
prin2t "\snext0 Normal;}";
prin2t "{\s2\fi-240\li480\sb80\tx480 \f11 \sbasedon0\snext2 nscba;}";
prin2t "{\s3\fi-240\li240\sa20 \f11 \sbasedon0\snext3 j;}";
prin2t "{\s4\li480\sa20 \f11 \sbasedon0\snext4 ij;}";
prin2t "{\s5\sb80\sa20 \f11 \sbasedon0\snext5 btb;}";
prin2t "{\s6\fi-240\li2400\sb20\sa20 \f11\fs20 ";
prin2t "\sbasedon0\snext6 ctcb;}";
prin2t "{\s7\fi-240\li480\sa40\tx480 \f11 \sbasedon0\snext7 ns;}";
prin2t "{\s8\sa120 \f11\fs28 \sbasedon0\snext8 TT;}";
prin2t "{\s9\fi-240\li2400\sa20 \f11 \sbasedon0\snext9 crtj;}";
prin2t "{\s10\fi-240\li480\tx480 \f11 \sbasedon0\snext10 nsca;}";
prin2t "{\s11\sa20 \f11 ";
prin2t "\sbasedon0\snext11 bt;}";
prin2t "{\s12\li240\sb120\sa40 \f11 \sbasedon0\snext12 Hf;}";
prin2t "{\s13\li240\sb120\sa40 \f11 \sbasedon0\snext13 Hs;}";
prin2t "{\s14\li480\sb120\sa40 \f11 \sbasedon0\snext14 RT;}";
princ "{\s15\fi-2160\li2160\sb240\sa80\tx2160 \f11";
prin2t " \sbasedon0\snext15 c;}";
prin2t "{";
prin2t "\s16\li2160\sa20 \f11 \sbasedon0\snext16 ct;}";
prin2t "{\s17\li240\sa20 \f11 \sbasedon0\snext17 it;}";
prin2t "{\s18\li480 \f11\fs20 \sbasedon0\snext18 nsct;}";
prin2t "{\s19\fi-160\li400\sb80\sa40 \f11 \sbasedon0\snext19 nscb;}";
prin2t "{\s20\fi-2640\li2880\sb120\sa40\brdrb\brdrs \brdrbtw\brdrs ";
prin2t "\tx2880 \f11 \sbasedon0\snext20 HC2;}";
princ "{\s21\fi-2640\li2880\sb120\sa20\tx2880 \f11";
prin2t " \sbasedon0\snext21 C2;}";
prin2t "{\s22\fi-240\li2400\sa20 \f11\fs20 \sbasedon0\snext22 ctc;}";
prin2t "{\s23\li2160\sb160 \f11 \sbasedon0\snext23 crt;}";
prin2t "{\s24\li480\sb20\sa40 \f11 ";
prin2t "\sbasedon0\snext24 or;}}";
terpri();
princ "{\info{\author Dan Davids}{\operator Dan Davids}";
prin2t "{\creatim\yr2137\mo8\dy7}";
princ "{\revtim\yr1990\mo5\dy9\hr16\min54}{\version3}";
prin2t "{\edmins3134}{\nofpages0}";
prin2t "{\nofwords65536}{\nofchars69885}{\vern8310}}";
terpri();
prin2t "\ftnbj \sectd \linex576\endnhere ";
prin2t "\pard\plain \sl240 \fs20 ";
terpri();
terpri();
terpri();
wrs o;
end;
symbolic procedure endoutput ();
begin
scalar o;
o := wrs outfile!*;
prin2t "}";
wrs o
end;
symbolic procedure verbatim u; !*verbatim := u;
symbolic procedure newfont(f);
if currentfont neq f then
<<fontoff(); currentfont:=f; fonton()>>;
symbolic procedure fontoff();
<<if !*font then channelprin2(outfile!*,"}");
outc:=nil;
!*font:=nil>>;
symbolic procedure fonton();
<<if not !*font then
<<channelprintf(outfile!*,"{\%w ",currentfont); outc := nil>>;
!*font:=t>>;
symbolic procedure myprin2 u;
<<!*newline:=nil; channelprin2(outfile!*,u)>>;
symbolic procedure myprin2_protected u;
<<if u memq '(!{ !}) then myprin2 "\";
myprin2 u;
>>;
fluid '(!*verbescape);
symbolic procedure emit_start_verbatim(); nil;
symbolic procedure emit_end_verbatim(); nil;
symbolic procedure verbprin2 u;
if u = '!\ then <<myprin2 u ; !*verbescape :=t>>
else
if u=!$eol!$ then <<myprin2 " \par"; myterpri();!*verbescape := nil>>
else
if (u = '!&) then
<<myprin2 "\tab "; !*verbescape:=par:=newl:=outc:=nil>>
else
if u memq '(!{ !}) then
<<if not !*verbescape then myprin2 "\"; myprin2 u;
!*verbescape := nil>>
else
<<myprin2 u; !*verbescape := nil>>;
symbolic procedure myterpri();
channelterpri outfile!*;
symbolic procedure number4out n;
% print number with 4 digits.
<< if n<10 then textout "0";
if n<100 then textout "0";
if n<1000 then textout "0";
textout n>>;
% par = t: paragraph has been terminated - no new data so far
% newl = t: last character has been an EOL
symbolic procedure textout(u);
if par and (u=!$eol!$ or u='! ) then nil else
<<fonton();
if u=!$eol!$ and (!*verbatim or newl)
then <<print_newline();
outc:='! ;
if not !*verbatim then second_newline();
newl:=nil;
par:=t>>
else
if (u = '!&) then
<<myprin2 "\tab "; par:=newl:=outc:=nil>>
else
if (u = '!$) then
newfont(if currentfont = helvetica then courier else helvetica)
else
if (u memq '(!{ !})) then <<myprin2 '!\; myprin2 u>> else
if (u neq '! ) or (outc neq '! ) or !*verbatim
then
<<if u=!$eol!$ and outc neq '! then myprin2 '! ;
myprin2(u); outc := u;
if u=!$eol!$ then newl:=t else
if u neq '! then newl:=nil;
par:=nil;
>>;
>>;
% -------- paragraph heading ---------------------------
symbolic procedure par_heading(type);
<<verbprin2 !$eol!$;
for each x in explode type do verbprin2 x;
verbprin2 ":";
verbprin2 !$eol!$;
>>;
% -------- directory structure -------------------------
symbolic procedure base_new_dir(name); nil;
symbolic procedure emit_dir_new(); nil;
symbolic procedure emit_dir_key u;
emit_node_key u;
symbolic procedure emit_dir_separator();
emit_node_separator();
symbolic procedure emit_dir_label u;
emit_node_label u;
symbolic procedure emit_dir_title u;
emit_node_title(u,nil,'section);
symbolic procedure emit_dir_browse(u,n);
emit_node_browse(u,n);
% ---- node structure
symbolic procedure emit_node_separator();
<<fonton();
myterpri(); myterpri();
channelprin2(outfile!*,"\page");
myterpri(); myterpri();
outc:='! ; par:=t;
>>;
symbolic procedure set_tab();
myprin2 "\pard \tx3420 ";
symbolic procedure release_tab();
myprin2 "\pard \sl240 ";
symbolic procedure textoutl(l);
% l is a list of characters to be printed.
% special action for names: \ in front of _ suppressed because
% of Microsoft HC logic (don't know why).
if atom l then textout l else
while l do
<<if not(car l = '!\) or null cdr l or not(cadr l = '!_)
then textout car l;
l := cdr l>>;
symbolic procedure textout2(l);
if atom l then myprin2 l else
for each x in l do myprin2
if x='! then '!_ else x;
symbolic procedure printem(s);
% print italic
begin
myprin2 "{\i ";
mapc(s,'myprin2);
myprin2 "} ";
end;
symbolic procedure printem(s);
begin
fontoff();
myprin2 "{\f3 ";
mapc(s,'myprin2_protected);
myprin2 "} ";
end;
symbolic procedure printref u;
begin scalar r;
r:= get_label u;
if null r then return printem u;
fontoff();
myterpri();
myprin2 "{\f2\uldb ";
mapc(u,'myprin2);
myprin2 "}{\v\f2 ";
mapc(r,'myprin2);
myprin2 "}"; myprin2 " ";
myterpri();
end;
symbolic procedure printnameref u;
printref u;
fluid '(key_database);
symbolic procedure emit_node_keys u;
begin scalar keys;
keys := assoc(u,key_database);
if null keys then return;
keys := cdr keys;
fonton();
myterpri();
myprin2 " K{\footnote \pard\plain \sl240 \fs20 K ";
while keys do
<<textoutl car keys; keys:= cdr keys;
if keys then myprin2";">>;
myprin2 "}";
myterpri();
end;
symbolic procedure emit_node_key u;
emit_hidden_node_key u;
symbolic procedure emit_hidden_node_key u;
if current_node!* then
begin scalar q;
q:= assoc(current_node!*,key_database);
if null q then
key_database := (current_node!* . {u}).key_database
else
if not member(u,cdr q) then cdr q:=u.cdr q;
end;
symbolic procedure emit_node_label u;
<<fonton();
myterpri();
myprin2 "#{\footnote \pard\plain \sl240 \fs20 # ";
textout2 u;
myprin2 "}";
myterpri();
>>;
symbolic procedure emit_node_title(u,dummy,type);
<<fonton();
myterpri();
myprin2 "${\footnote \pard\plain \sl240 \fs20 $ ";
textoutl u;
myprin2 "}";
myterpri();
>>;
symbolic procedure emit_node_browse(u,n);
<<fonton();
myterpri();
myprin2 "+{\footnote \pard\plain \sl240 \fs20 + ";
textout u;
textout ":";
number4out n;
myprin2 "}";
myterpri();
>>;
symbolic procedure print_bold u;
<<fontoff();
myprin2 "{\b\f2 ";
mapc(u,'myprin2);
myprin2 "}";
>>;
symbolic procedure emit_dir_header();
<<fontoff();
myprin2 "{\f2 \par }\pard \sl240 {\f2 \par }";
myterpri();
>>;
symbolic procedure emit_dir_entry(name,lab);
begin scalar alias;
fontoff();
myprin2 "{\f2 \tab}{\f2\uldb ";
mapc(name,'myprin2);
myprin2 "}";
myterpri();
myprin2 "{\v\f2 ";
textout2 lab;
myprin2 "}";
if (alias:=assoc(lab,aliases)) then
<<myprin2 " "; myprin2 cdr alias>>;
print_newline();
end;
symbolic procedure print_newline();
<<if null !*newline then
<<fonton(); channelprin2(outfile!*,"\par "); channelterpri outfile!*>>;
!*newline:=t
>>;
symbolic procedure second_newline();
<<!*newline :=nil; print_newline()>>;
symbolic procedure print_tab ();
<<fonton(); myprin2 "\tab ">>;
%------------------- printstruct -------------------------------
symbolic procedure printstruct();
<<terpri(); printstruct1(car record,1)>>;
symbolic procedure printstruct1(r,n);
<<for i:=1:n do prin2 " ";
mapc(name r,'prin2);
terpri();
for each x in reverse seq r do
printstruct1(nil . x,n+1);
>>;
end;