/*  --- Copyright University of Sussex 2001.  All rights reserved. ---------
 >  File:           $poplocal/local/lib/bibtool.p
 >  Purpose:        Re-implementation of UNIX "bib" package
 >  Author:         Chris Thornton, July 1987 (see revisions)
 >  Documentation:  HELP * BIBTOOL, HELP * MENUSELECT
 >  Related Files:
 */
/*

          CONTENTS - (Use <ENTER> g to access sections)

 -- Configuration for local network resources
 -- Bibtool formatting programs
 -- Run-time setup of user-assignable vars
 -- System constants
 -- System vars
 -- Basic list/string functions
 -- Special-purpose field functions
 -- Processing bibtoolprog fields
 -- Processing references
 -- Dealing with raw-form references
 -- Setting up the "current" vars
 -- Sortbib
 -- Addbib
 -- Lookbib
 -- Refer
 -- Input utilties
 -- Output utilities
 -- Command interpreter
 -- ENTER commands
 -- Printer/virtual-printer commands

 */

uses menuselect;
uses ditrofflib;
uses ved_ms;
max(400000, popmemlim) -> popmemlim;

/*
-- Configuration for local network resources --------------------------
*/
vars
   bib_hosts = [
      %  if systranslate('DOMAIN')='edinburgh' then
            dl(['forth' 'solway' 'don' 'dan'])
         else
            dl(['csunb' 'csuna' 'trl-sun' 'lpe-sun' 'pas-sun' 'cora'])
         endif % ],
   bib_nroff_coms = [
      %applist(bib_hosts,
         procedure(s);
            'rsh '><s><' nroff | col';
            'rsh '><s><' nroff';
            'rsh '><s><' nroff -Tlp';
            'rsh '><s><' nroff -Ttn300';
         endprocedure) %
         'nroff -man'
         ],
   bib_lp_coms = [
      %  if systranslate('DOMAIN')='edinburgh' then
            dl(['lpr -h -Plw' 'lpr -PneSB' 'lpr -PbigSB'])
            /* 'rsh forth /usr/local/bin/enscript -Plw -l' */
         else
            dl(['rsh csuna lpr -Ptpb'
            'rsh csuna lpr -Pljb'
            'rsh csuna lpr -Ptpa'
            'rsh unx1 tpr'
            'rsh csuna lpr -Plja'
            'rsh csuna lpr -Plpa'
            'rsh csuna lpr -Plpb'])
         endif % ],
   bib_troff_coms = [
      % if systranslate('DOMAIN')='edinburgh' then
            'rsh forth troff';
            /* %'rsh forth ' >< sysfileok('$ditrofflib/bin/troff') ><
            ' -Plw -F' >< sysfileok('$ditrofflib/fontdir') % */
        else
            'rsh csuna troff'
        endif % ],
   bib_ts_coms = [^vednullstring 'rsh forth ptroff'],
   bib_nroff_com = hd(bib_nroff_coms),
   bib_troff_com = hd(bib_troff_coms),
   bib_lp_com = hd(bib_lp_coms),
   bib_ts_com = hd(bib_ts_coms);


/*
-- Bibtool formatting programs ----------------------------------------
*/

vars bibtoolprogs x, bib_ref_type, bib_ref_title;
define bib_newprogs;
   vars default_pre_op = [.join_lines;.capitalise;];
   newproperty([
   [APA [[
         [['%A' rev_author_names ' ' '']
          ['%E' [.rev_author_names; .add_default_eds;] ' ' '']
          ['%Q']]
         ['%D' parse_date_year_only ' (' ').']
         ['%Q']
         ['%T' capitalise_first_word ' ' '.']
         ['%E' [.format_author_names; .add_default_eds] ' In ' ',']
         ['%B' pre_process_main_title ' ' '.']
         ['%J' pre_process_main_title]
         ['%(' ^default_pre_op ' (' ')']
         ['%G']
         ['%R']
         ['%S']
         [if bib_ref_type="j" do ['%V' add_suitable_title_trim] else 0 endif]
         [if bib_ref_type/="j" do ['%V' ^default_pre_op ' Vol. ' ','] else 0 endif]
         ['%N' ^default_pre_op ' No. ' ',']
         [if bib_ref_type="b" and issubstring('roceedings',2,bib_ref_title(1)) do ['%P' put_default_pagenum_prefix ' (' ').'] else 0 endif]
         [if bib_ref_type="j" do ['%P'] else 0 endif]
         ['%C' capitalise ' ' ':']
         ['%I']
         ['%O' join_lines ' (' '),' join_strings]
         ['%' substitute_with_nil 0 0]
         ]]]
   [roffbib [[
         [['%A' rev_author_names ' ' '']
          ['%E' [.rev_author_names; .add_default_eds;] ' ' '']
          ['%Q']]
         ['%D' parse_date ' (' ')']
         ['%Q']
         ['%T' capitalise ' "' '",']
         ['%E' [.format_author_names; .add_default_eds] ' in ' ',']
         [{'%B' '%J'} [.capitalise; .add_suitable_title_trim] ' ' '.']
         ['%(' identfn ' (' ')']
         ['%G']
         ['%R']
         ['%S']
         ['%V' identfn ' vol. ' ',']
         ['%N' identfn ' no. ' ',']
         ['%I']
         ['%C']
         ['%P' put_default_pagenum_prefix]
         ['%O' join_lines ' (' '),' join_strings]
         ['%' substitute_with_nil 0 0]
         ]]]
   [AI_journal [[
         [['%A' rev_author_names ' ' '']
          ['%E' [.rev_author_names; .add_default_eds;] ' ' '']
          ['%Q']]
         ['%Q']
         ['%T' capitalise_first_word ' ' '.']
         ['%E' [.format_author_names; .add_default_eds] ' In ' ',']
         ['%B' pre_process_main_title ' ' '.']
         ['%J' pre_process_main_title]
         ['%G']
         ['%R']
         ['%S']
         [bib_ref_type="j" and ['%V' add_suitable_title_trim]]
         [bib_ref_type/="j" and ['%V' ^default_pre_op ' Vol. ' ',']]
         /* ['%N' ^default_pre_op ' No. ' ','] */
         ['%I']
         ['%C']
         ['%D' parse_date_year_only ' (' ')']
         [bib_ref_type="j" and ['%P'] or ['%P' put_default_pagenum_prefix]]
         ['%O' join_lines ' (' '),' join_strings]
         ['%' substitute_with_nil 0 0]
         ]]]
   [old_AI_journal [
      [
      [['%A' rev_author_names]
       ['%E' [.rev_author_names; .add_default_eds]]
       ['%Q']]
      ['%Q']
      ['%T' [.join_lines;.uppertolower_tail] ' ' ',']
      ['%E' [add_eds(' (Eds.)', ' (Ed.)')] ' in ']
      ['%B' [.capitalise;.add_suitable_title_trim;0 -> putb] ' ' ',']
      ['%J' [.capitalise;.add_suitable_title_trim;0 -> putb] ' ' '']
      ['%(' ^default_pre_op ' (' ')']
      ['%V' embolden ' ' '']
      ['%N' ^default_pre_op '(' ')']
      ['%G']
      ['%S']
      ['%R']
      ['%I' join_lines [if putb do 1 -> putb endif;putb and ' (' or ' ']]
      ['%C']
      ['%D' parse_date [putb == 1 and ' ' or putb and ' (' or ' ']
            [putb and '),' or ','] join_strings]
      ['%P']
      ['%K' substitute_with_nil 0 0]
      ['%O' ^default_pre_op '\n' ' ' join_lines]
      ][vars putb = false] [.join_strings;splice_all(', (', ' (');splice_all
         (',  (',' (');.add_finish_justify]]]
   /* Format with full "tail-bracketing" -- very close to Sussex/Dphil */
   [sussex_thesis [
      [
      [['%A' rev_author_names]
       ['%E' [.rev_author_names; .add_default_eds]]
       ['%Q']]
      ['%Q']
      ['%T' capitalise ' "' '"']
      [{'%J' '%B'} [.capitalise;.add_suitable_title_trim] ' ' '.']
      ['%G']
      ['%E' add_default_eds ' in: ']
      ['%(' ^default_pre_op ' (' ')']
      ['%S']
      ['%R']
      ['%I' ^default_pre_op ' (' 0 [true -> put_open_bracket]]
      ['%C']
      ['%D' parse_date ' ' [if put_open_bracket do ')' else ',' endif]]
      ['%V' ^default_pre_op ' V. ' ',']
      ['%N' ^default_pre_op ' No. ' ',']
      ['%P']
      ['%K' substitute_with_nil 0 0]
      ['%O' substitute_with_nil 0 0]
      ] 0 0 [vars put_open_bracket = false]]]
   [sussex_fac [
      [
      ['%A' sussex_fac_author_names '' ',']
      ['%Q']
      ['%T' capitalise ' "' '",']
      ['%J' [true -> isjournal;.capitalise; .add_suitable_title_trim] ' ' ' ']
      ['%B' [.capitalise;.add_suitable_title_trim] ' ' '.']
      ['%G']
      ['%E' add_default_eds ' in ']
      ['%(' ^default_pre_op ' (' ')']
      ['%R']
      ['%S']
      ['%C' ^default_pre_op ', ' ':']
      ['%I']
      ['%V' ^default_pre_op ' Vol. ' ',']
      ['%N' ^default_pre_op ' No. ' ',']
      ['%D' parse_date [isjournal and ' (' or ' '][isjournal and '),' or ',']
            join_strings]
      ['%P' [put_pagenum_prefix(if isjournal then '','' else 'P.', 'Pp.' endif)]]
      ['%K' substitute_with_nil]
      ['%O' substitute_with_nil]
         ] [vars isjournal = false;] add_finish_fill_tl
               identfn identfn ['%' join_lines ' ' ',' join_strings]]]
   [khabaza [[
         [['%A' [.lowertoupper_major;.rev_author_names] ' ' '']
          ['%E' [.lowertoupper_major; .rev_author_names;.add_default_eds;] ' ' '']
          ['%Q']]
         ['%D' parse_date ' (' ')']
         ['%Q']
         ['%T' capitalise ' ' ',']
         ['%E' add_default_eds ' in ' ',']
         [{'%B' '%J'} ^default_pre_op ' "' '".']
         ['%(' ^default_pre_op ' (' ')']
         ['%G']
         ['%R']
         ['%S']
         ['%V' ^default_pre_op ' Vol. ' ',']
         ['%N' ^default_pre_op ' No. ' ',']
         ['%I']
         ['%P' put_default_pagenum_prefix]
         ['%' substitute_with_nil 0 0]
         ]]]
   [structured [[
         [['%A' [.lowertoupper_major;.rev_author_names]]
          ['%E' [.lowertoupper_major; .rev_author_names;.add_default_eds;]]
          ['%Q']]
         ['%D' parse_date ' (' ')' [.conspair;.join_strings]]
         ['%Q']
         ['%T' capitalise '' ',']
         ['%E' add_default_eds ' in ' ',']
         [{'%B' '%J'} [.join_lines;.add_suitable_title_trim] '' '.']
         ['%(' ^default_pre_op '(' ')']
         ['%G']
         ['%R']
         ['%S']
         ['%V' ^default_pre_op 'Vol. ' ',']
         ['%N' ^default_pre_op 'No. ' ',']
         ['%I']
         ['%P' put_default_pagenum_prefix]
         ['%' substitute_with_nil 0 0]
         ] [] add_finish_nofill
               identfn identfn ['%' join_lines '' ',' join_strings]]]
   [null [[][] add_finish_nofill]]
   ],16,[
      /* default program */
      []
      [] add_finish_justify
      identfn identfn
      ['%' ^default_pre_op ' ' ',' join_strings]
      ],true) -> bibtoolprogs;
enddefine;

bib_newprogs();

/*
-- Run-time setup of user-assignable vars -----------------------------
*/


/* User-assignable variables */
vars corebibname bibsearchlist
   bib_vert_spaces
   bib_pre_bib_strings bib_pre_ref_strings
   bib_post_bib_strings bib_post_ref_strings
   bib_sort_strategy bib_refer_sort_strategy
   bib_initials_only bib_nvp_translate_codes
   bib_et_al_abbreviate bib_force_wait bib_full_justify
   bib_roffjob_maxtime bib_lookall bib_ref_centuries
   bib_open_brackets bib_output_pseudonyms,
   bib_bibliography_title,
   bib_ibid_abbreviate, bib_ignore_case, bib_ibid_limit;


/* Conditional assignment pdr */
define 7 y ?= x; if isundef(valof(y)) then x -> valof(y) endif; enddefine;
define 7 y ?= x; x -> valof(y) enddefine;


define run_time_setup;
   lvars b; vars set_current_program_&_target, not_core_citation;
   set_current_program_&_target('');
   if isundef(bibsearchlist) then
      [% systranslate('HOME') dir_>< 'corebib' %] -> bibsearchlist;
   elseunless ispair(bibsearchlist) do
        mishap('BIBSEARCHLIST not set up as a list', [])
   endif;
   hd(bibsearchlist) -> corebibname;
   "bib_bibliography_title" ?= 'REFERENCES',
   "bib_vert_spaces" ?= newassoc([[roff 0][screen 1][lp 1][null 1][tex 1]]),
   "bib_pre_bib_strings" ?=
      newproperty([[roff
         {^vednullstring
          '.if t .in 0.35i' '.if t .ta 0.35i'
          '.if n .in 5n' '.if n .ta 5n'
          '.ne 4' '.ce 1' }]
         [tex {'' '\\begin{document}' '\\ind{0.5i}'}]
         ],16,{^vednullstring},true),
   "bib_pre_ref_strings" ?=
         newproperty([[roff {'.ti 0'}][tex {'\\tmpind{-0.25i}'}]],16,[],true),
   "bib_post_ref_strings" ?=
         newproperty([[lp ['\n\n', dl(bib_X_field_strings)]]],16,[],true),
   "bib_post_bib_strings" ?= newproperty([[roff {'.in 0'}]],16,[],true),

   /* Booleans */
   "bib_sort_strategy" ?= "author_date",
   "bib_refer_sort_strategy" ?= false,
   "bib_initials_only" ?= true,
   "bib_nvp_translate_codes" ?= false,
   "bib_et_al_abbreviate" ?= true,
   "bib_force_wait" ?= false,
   "bib_full_justify" ?= false,

   /* User-assignable simple variables */
   "bib_roffjob_maxtime" ?= 60,
   "bib_lookall" ?= false,

   /* Refer configuration */
   "bib_ref_centuries" ?= ['19' '18' '17' '16' 'forthcoming'],
   "bib_open_brackets" ?=
      ['[' '(' ';' 'see' 'See' ':' 'c.f.' 'cf.'
      'e.g.' 'eg.' 'i.e.' 'ie.' 'also'],

   "bib_output_pseudonyms" ?= newassoc([[dvp ditroff_vprinter]
         [np nroff_printer][tp troff_printer]
         [nvp nroff_vprinter][tvp troff_vprinter]]);
   "bib_ibid_abbreviate" ?= true;
   "bib_ignore_case" ?= true;
   "bib_ibid_limit" ?= 20;
   identfn -> run_time_setup;
enddefine;

/*
-- System constants ---------------------------------------------------
*/

constant AND_strings = [' &' ' AND' ' and'],
         raw_author_key = '%A  ',
         addbib_mapping = [
            ['Authors:' '%A']
            ['Title:' '%T']
            ['Book:' '%B']
            ['Report:' '%R']
            ['Title annotation:' '%(']
            ['Eds:' '%E']
            ['Journal:' '%J']
            ['Volume:' '%V']
            ['Number:' '%N']
            ['Issuer:' '%I']
            ['City:' '%C']
            ['Date:' '%D']
            ['Pages:' '%P']
            ['Reference annotation:' '%O']
            ['Abstract:' '%X']
            ['Series title:' '%S']
            ['Keys:' '%K']],
         addbib_file = '.addscratch',
         uncapitalisable_words =
            ['who' 'any' 'an' 'which' 'out' 'more' 'concerning' 'by'
            'we' 'do' 'with' 'that' 'through' 'from' 'to' 'called'
            'this' 'is' 'between' 'their' 'some' 'a' 'as' 'into' 'the'
            'at' 'on' 'a' 'for' 'the' 'of' 'in' 'and' 'an' 'or'],
         target_specs = [roff lp screen null tex],
         /* Special keys */
         direct_flag = '.', range_flag = 'mr', buffer_flag = '*',
         cit_flag = 'c',

         nroff_spec = 'nroff_printer', troff_spec = 'troff_printer',
         printer_spec = 'printer',
         nroff_vprinter_spec = 'nroff_vprinter',
         troff_vprinter_spec = 'troff_vprinter',
         ditroff_vprinter_spec = 'ditroff_vprinter';

/*
-- System vars --------------------------------------------------------
*/

vars

   bib_X_field_strings,
   bib_K_field_strings,
   bib_core_authors,
   bib_style_spec = "APA",
   bib_target_spec = "screen",
   bib_output_file = 'bib.out',

   background_bibjob,
   style_specs = maplist(datalist(bibtoolprogs), hd),
   lookbib_found = corebibname, citation_bibloc,
   bib_refs_cited = [],
   no_core_check = false, bib_bad_citations, cbc_citations, bib_good_citations,
   sysobey_doublefork = true,
   bibjob_message = vedputmessage,
   bib_author_AND_string = '& ',
   bib_citation_punctuation_strings =
      [',' 'and' '&' 'AND' '\\' 'et' 'al' 'al.' '.'],
   bib_mixed_case_field_keys = [`O `X `A `E `H `K `L `M `N `(],
   job_flag = '|', default_job_spec = '',

   current_target_spec = bib_target_spec,
   current_style_spec = bib_style_spec,
   current_program, current_job_spec, current_program, current_args,
   current_output, current_input, current_input_spec, current_output_spec,
   current_citations_map, core_input, core_citations_map,

   Filters = 1,
   Pre_process_fields = 2, Post_process_fields = 3,
   Pre_process_bib = 4, Post_process_bib = 5,
   Default_filter = 6,

   fields, write_buffers, ved_nbm, printing_linelength, sort_bib,
   sysobey_output, ved_cat, ved_ncb vedput_processed_bib
   full_refer bib_raw_input = {}, bibreadin, do_core_check, insert_refs,
   join_lines add_suitable_title_trim trim_line;



/*
-- Basic list/string functions ----------------------------------------
*/

define skipchar_back_all(chars, index, s);
   lvars char x i, index,  index s;
   fast_for i from index by -1 to 1 do
      unless fast_lmember(fast_subscrs(i, s), chars) do
         return(i)
      endunless;
   endfor;
   false
enddefine;

define make_all_strings(list);
   lvars string list;
   [% until list == [] do
         fast_destpair(list) -> list -> string;
         if isstring(string) then string else string >< '' endif
      enduntil %]
enddefine;

define try_splice(string, target_substring, new_substring) -> string;
   lvars start target_substring, n;
   if not(target_substring) do new_substring >< string -> string; return endif;
   datalength(target_substring) -> n;
   if (issubstring(target_substring, 1, string) ->> start) then
      substring(1, start fi_- 1, string) ><
            new_substring ><
            substring(start fi_+ n,
            datalength(string) fi_- (start fi_+ n) fi_+ 1, string)
            -> string;
   else
      false -> string;
   endif
enddefine;


define lconstant splice(s,t,n) -> s;
	;;; make lconstant to prevent clashes. A.S. 4 Feb 2001
   lvars s t n new_s;
   while try_splice(s,t,n) ->> new_s do
      new_s -> s;
   endwhile;
enddefine;


define do_splices(string, pairs) -> string;
   lvars pair pairs;
   for pair in pairs do
      splice(string, pair(1), pair(2)) -> string
   endfor;
enddefine;

define wrapped_substring(sub, j, str);
   lvars n = datalength(sub), i = 1, m = datalength(str);
   until i fi_> n do
      if fast_subscrs(j, str) /== 10 then
         if fast_subscrs(i, sub) /== fast_subscrs(j, str) do return(false) endif;
         i fi_+ 1 -> i;
      endif;
      j fi_+ 1 -> j;
      if j fi_> m do return(false) endif;
   enduntil;
   return(true);
enddefine;

define substitute_in(strings, old, new) -> strings;
   lvars string i = 1, assignments, char, old_n = datalength(old), new_i, i, new_n = datalength(new), string_n ;
   cons_with consstring {%
       for string in strings do explode(string); 10; endfor; %} -> string;
   until i fi_> datalength(string) do
      if wrapped_substring(old,i,string) then
         1 ->> new_i -> assignments;
         until assignments fi_> old_n do
            if string(i) /== 10 then
               assignments fi_+ 1 -> assignments;
               if new_i > new_n then
                  0 -> string(i)
               else
                  new(new_i) -> string(i);
                  new_i + 1 -> new_i;
               endif;
            endif;
            i fi_+ 1 -> i;
         enduntil;
      endif;
      i fi_+ 1 -> i;
   enduntil;
   datalength(string) -> string_n;
   1 -> i;
   [  %until i fi_> string_n do
          cons_with consstring
          {  %until i fi_> string_n do
                 string(i) -> char;
                 i fi_+ 1 -> i;
              quitif(char = 10);
                 if char /== 0 then char endif;
              enduntil %}
       enduntil %] -> strings;
enddefine;

/* define splice_out(unwanted, str) -> str;
   lvars i = 1, n = length(unwanted), j;
   while (issubstring(unwanted,i,str) ->> i) do
      substring(1,i-1,str) >< substring(i+n ->> j,datalength(str)-j+1,str)
      -> str
   endwhile;
enddefine; */

define splice_out_all(strings, bad_strings);
   lvars string strings bad_strings;
   [%  for string in strings do
          unless member(string, bad_strings) do string endunless;
       endfor %]
enddefine;

/* define splice_out_all(strings, bad_strings);
   vars bad_string, string;
   [ % for string in strings do
          for bad_string in bad_strings do
             splice_out(bad_string, string) -> string;
          endfor;
          string;
       endfor % ]
enddefine; */

define splice_all(list, targ, new);
   lvars list new targ;
   maplist(list, splice(%targ, new%))
enddefine;

define extend_string(str, n);
   lvars str m n s;
   if (datalength(str) ->> m) < n then
      set_bytes(32, 1, inits(n - m ->> n) ->> s, n);
      str >< s
   else
      str
   endif
enddefine;

define make_buffer(n);
   consvector(repeat n times vednullstring endrepeat, n)
enddefine;

define make_repeater(rec);
   /* rec contains a subscript and a list of strings.
   subscript is a subscript, string the current string,
   stringlist the list of strings */
   lvars rec string stringlist subscript _pos;
   fast_destpair(rec) -> stringlist -> subscript;
   if null(stringlist) then return(termin) endif;
   fast_front(stringlist) -> string;
   if subscript fi_> datalength(string) then
      /* end of that line, prepare for next one */
      fast_back(stringlist) ->  fast_back(rec);
      1 -> fast_front(rec);
      `\n`
   else
      fast_subscrs(subscript, string);
      subscript fi_+ 1 -> fast_front(rec);
   endif
enddefine;


define find_index(pdr, str) -> i -> n;
   lvars i = 1, c, n = 0, str pdr, m = datalength(str);
   until i fi_> m
   or pdr(i,n) do
      if (fast_subscrs(i, str) ->> c) == 8 then
         n fi_- 1 -> n;
      elseif c == 27 or c == 14 then
         i fi_+ 1 -> i
      elseif c fi_>= 32 then
         n fi_+ 1 -> n;
      endif;
      i fi_+ 1 -> i;
   enduntil;
enddefine;


define printing_linelength(max_linelength, str) -> n;
   lvars str max_linelength i n;
   find_index(
      procedure(i,n,m);
         m and n fi_> m
      endprocedure(%max_linelength%), str) -> i -> n;
enddefine;


define effective_cutoff(print_length, str) -> i;
   find_index(
      procedure(i,n,print_length);
         n fi_>= print_length
      endprocedure(%print_length%), str) -> i -> n;
   if n fi_>= print_length then i fi_- 1 -> i endif;
enddefine;


define first_printing_char(str) -> i;
   lvars str i n;
   find_index(
      procedure(i,n,str);
         isalphacode(fast_subscrs(i,str))
         and (i fi_< 2 or fast_subscrs(i fi_- 1, str) /== 27)
      endprocedure(%str%), str) -> i -> n;
enddefine;

define move_chars(i1,s1,i2,s2,n);
   lvars m = i2 fi_+ n, i1, s1, s2, i2, n;
   until i2 fi_>= m do
      if fast_subscrs(i2,s2) == ` ` then
         fast_subscrs(i1,s1) -> fast_subscrs(i2,s2)
      endif;
      i2 fi_+ 1 -> i2;
      i1 fi_+ 1 -> i1;
   enduntil
enddefine;

/* only interprets backwinds: i.e. <ESC>9 */
define interpret_escape_codes(file) -> result;
   lvars c, i = 1, buffer, rep new_string new_string_start
        new_string_length
        old_string, buffer_size = 500, charlist offset offset_start
        old_string_length, chars;

   define windback_char;
      not(null(charlist))
      and not(null(tl(charlist)))
      and charlist(1) = 27
      and charlist(2) = `7
   enddefine;

   define windback;
      while windback_char() do
         i - 1 -> i;
         tl(tl(charlist)) -> charlist;
      endwhile;
   enddefine;

   define end_of_line_char;
      not(null(charlist)) and charlist(1) = 10
   enddefine;

   define windon;
      while end_of_line_char() do tl(charlist) -> charlist; i+1 -> i endwhile
   enddefine;

   make_buffer(buffer_size) -> buffer;
   if islist(file) then
      make_repeater(%conspair(1, file)%)
   elseif isvector(file) do
      make_repeater(%conspair(1, [% explode(file) %])%)
   elseif isstring(file) then
      discin(file)
   else
      mishap('Can\'t read file', [^file])
   endif -> rep;
   pdtolist(rep) -> charlist;

   until null(charlist) do
      0 -> chars;
      cons_with consstring {%
          until null(charlist) do
             quitif(windback_char() or end_of_line_char());
             dest(charlist) -> charlist ->> c; /* Char left on stack */
             chars + 1 -> chars;
             /* get rid of half-winds */
             if chars fi_> 1 and (c == `8 or c == `9)
             and subscr_stack(2) == 27 then
                erase(); erase(); chars fi_-2 -> chars;
             endif;
          enduntil %} -> new_string;
      /* Check that new buffer is still large enough. */
      if i > buffer_size then
         buffer <> make_buffer(buffer_size) -> buffer;
         buffer_size * 2 -> buffer_size;
      endif;
      skipchar(32,1,new_string) or 1 -> new_string_start;
      datalength(new_string) -> new_string_length;
      fast_subscrv(i, buffer) -> old_string;
      datalength(old_string) -> old_string_length;
      old_string_length - printing_linelength(false, old_string) -> offset;
      extend_string(old_string, new_string_length + offset) -> old_string;
      move_chars(new_string_start, new_string,
               new_string_start + offset, old_string,
               new_string_length - new_string_start + 1);
      old_string -> fast_subscrv(i, buffer);
      if windback_char() then windback() else windon() endif;
   enduntil;
   vedusedsize(buffer) -> n;
   initv(n) -> result;
   move_subvector(1,buffer,1,result,n);
enddefine;


define cons_blank_string(n);
   lvars n;
   consstring(repeat n times 32 endrepeat, n)
enddefine;


/* Fast substring-checking procedure. */
define substr(sub,j,str);
   lvars i = 1, sub str j, n = datalength(sub), m = datalength(str);
   if (j fi_+ n fi_- 1) fi_> m then return(false) endif;
   until i fi_> n do
      if fast_subscrs(i,sub) /== fast_subscrs(j,str) then
         return(false)
      endif;
      j fi_+ 1-> j;
      i fi_+ 1 -> i;
   enduntil;
   true
enddefine;


define nodups(list);
   lvars item list;
   [% until list == [] do
         fast_destpair(list) -> list -> item;
         unless member(item, list) do item endunless;
      enduntil %]
enddefine;


define substitute_with_nil;
   erase();
   []
enddefine;


define split_at_newlines(str);
   lvars str i n ;
   [% until not(locchar(10, 1, str) ->> i) do
         substring(1, i - 1, str);
         substring(i + 1, datalength(str) - i, str) -> str;
      enduntil; if str /= '' do str endif %]
enddefine;


define un_><(str);
   lvars s, str, ind = vedindentstep, linelength = vedlinemax - 10, n, cutoff;
   if str = '' do return([^str]) endif;
   if isinteger(str) then str -> linelength; -> str endif;
   [% repeat
         if printing_linelength(false, str) fi_<= linelength then
            substring(skipchar(` `,1,str) or 1 ->> s,
                  datalength(str) - s + 1, str);
            quitloop
         else
            effective_cutoff(linelength, str) -> cutoff;
            locchar_back(10, cutoff, str)
            or locchar_back(` `, cutoff, str) or cutoff -> s;
            skipchar(` `,1,str) or 1 -> n;
            max(n,s) -> s;
            substring(n, s - n + 1, str);
            substring(s + 1, datalength(str) - s, str) -> str;
         endif;
         linelength fi_- ind -> linelength;
         0 -> ind;
      endrepeat;
      /* Get rid of any blank lines at the end. */
      until (dup() -> str, str = popstackmark or skipchar(` `,1,str)) do
         erase()
      enduntil; %]
enddefine;


define un_><_all(str);
   maplist(split_at_newlines(str), un_>< pdcomp dl)
enddefine;


define ><_all(list);
   vars cucharout = identfn, put_spaces = false; lvars item list;
   if isboolean(list) then list -> put_spaces; -> list endif;
   cons_with consstring
         {% for item in list do
               pr(item);
               if put_spaces then pr(space) endif;
            endfor;
            if put_spaces then erase() endif; %}
enddefine;

define invisible_ved_apply(b);
   vars interrupt, vedediting = false;
   lconstant struc = initv(34); /* must be right size for a VED structure! */
   if not(isvector(b)) then mapdata(vedbuffer, copy) -> b endif;
   if isboolean(dup()) then -> vedediting endif;

   procedure(struc, old);
      vedsetglobals(struc);
      vedrefresh();
      old();
   endprocedure(%struc, interrupt%) -> interrupt;

   vedsaveglobals(struc);
   b -> vedbuffer;
   vedbufferextend();
   apply();
   vedsetglobals(struc);
enddefine;

define justify(strings, indent);
   vars vedediting = false, pdr;
   procedure(indent);
      lvars i pdr;
      1 -> vvedmarklo;
      vvedbuffersize -> vvedmarkhi;
      vedjumpto(1,1); vedsetlinesize();
      vedbufferextend();
      if bib_full_justify then ved_jj else ved_fill endif -> pdr;
      pdr();
      if indent then
         vedindentstep -> vedleftmargin;
         2 -> vvedmarklo;
         vedusedsize(vedbuffer) -> vvedmarkhi;
         pdr();
      endif;
      [% for i from 1 to vedusedsize(vedbuffer) do vedbuffer(i) endfor %];
   endprocedure(%indent%) -> pdr;
   invisible_ved_apply(pdr, {% applist(un_><_all(><_all(strings)), copy) %});
enddefine;

/* define apply_ved_using_pdr(b);
   vars interrupt;
   lconstant struc = initv(34); /* must be right size for a VED structure! */

   procedure(struc, old);
      vedsetglobals(struc);
      vedrefresh();
      old();
   endprocedure(%struc, interrupt%) -> interrupt;

   vedsaveglobals(struc);
   b -> vedbuffer;
   apply();
   vedsetglobals(struc);
enddefine; */

define justify_ref;
   justify(true)
enddefine;

define fill_ref;
   vars bib_full_justify = false;
   justify(false);
enddefine;

define justify_ref_tail(strings) -> strings;
   vars vedleftmargin = vedindentstep;
   justify(tl(strings), false) -> tl(strings)
enddefine;

define put_white_space(strings, indent_spaces);
   vars vedleftmargin = indent_spaces;
   justify(strings, false)
enddefine;


define join_lines(strings);
   lvars strings str;
   if strings == [] then
      []
   else
      ><_all(strings, true) -> str;
      [^str]
   endif
enddefine;


define join_strings(strings) -> strings;
   lvars strings;
   [% ><_all(strings) %] -> strings;
enddefine;


define lowertoupper_all;
   maplist(lowertoupper)
enddefine;


define lowertoupper_major(strings) -> result;
   lvars string words lower_word result word;
   if strings == [] then return endif;
   [% for string in strings do
         cons_with consstring {%
             sysparse_string(string) -> words;
             unless words == [] do
                destpair(words) -> words -> word;
                explode(lowertoupper(word));` `;
             endunless;
             for word in words do
                if member(uppertolower(word) ->> lower_word, uncapitalisable_words) then
                   lower_word
                else
                   lowertoupper(word)
                endif.explode;
                ` `;
             endfor -> %}
       endfor %] -> result;
enddefine;


define lp_underline(str);
   cons_with consstring
         {% appdata(str, procedure(c); `_, 8, c endprocedure) %}
enddefine;


define lp_underline_all;
   maplist(lp_underline)
enddefine;


define uppertolower_tail(strings) -> strings;
   lvars strings string i;
   maplist(strings, uppertolower) -> strings;
   for string in strings do
      if (skipchar(32,1,string) ->> i) then
         lowertoupper(string(i)) -> string(i);
         return
      endif;
   endfor
enddefine;


define add_defaults(list, defaults) -> list;
   lvars list defaults n, m = listlength(defaults);
   if (listlength(list) ->> n) < m then
      list <> allbutfirst(n, defaults)
         -> list
   endif;
enddefine;


/*
-- Special-purpose field functions ----------------------------------
*/

define embolden(strings) -> strings;
   if current_target_spec == "roff" then
      /* ['\\fB' ^^strings '\\f'] -> strings; */
      ['\n.bd 1 3\n' ^^strings '\n.bd 1\n'] -> strings;
      /* ['\n.b\n' ^^strings '\n.b\n'] -> strings; */
   elseif current_target_spec == "lp" then
      /* ??? */
   endif;
enddefine;


define uppertolower_normal_words(string) -> string;
   lvars i = 1, char, n = datalength(string), next;
   until i fi_> n do
      fast_subscrs(i, string) -> char;
      i fi_< n and fast_subscrs(i + 1, string) -> next;
      if isuppercode(char) and (i == 1 or fast_subscrs(i-1,string) == ` `)
      and (next == `.` or isuppercode(next)) then
         locchar(` `, i, string) or n -> i;
      else
         if isuppercode(char) then uppertolower(char) -> string(i) endif;
      endif;
      i fi_+ 1 -> i;
   enduntil;
enddefine;

define capitalise_first_word(strings) -> strings;
   lvars strings = maplist(strings, uppertolower_normal_words), string = hd(strings);
   lowertoupper(string(1)) -> string(1);
   [^string ^^(tl(strings))] -> strings;
enddefine;

define capitalise(strings) -> result;
   lvars string strings words word result = strings, lower_word, i;
   if strings == [] then return endif;
   ><_all(strings, true) -> string;
   make_all_strings(sysparse_string(string)) -> words;
   cons_with consstring {%
      unless words == [] do
         destpair(words) -> words -> word;
         lowertoupper(word(1)) -> word(1);
         deststring(word) ->; ` `;
      endunless;
      for word in words do
         uppertolower(word) -> lower_word;
         if member(lower_word, uncapitalisable_words) then
            lower_word
         else
            if word(1) == `( then 2 else 1 endif -> i;
            lowertoupper(word(i)) -> word(i);
            word
         endif.explode;
         ` `;
      endfor; -> %} -> string;
   [^string] -> result;
enddefine;

define pre_process_main_title(strings) -> strings;
   strings -> bib_ref_title;
   add_suitable_title_trim(capitalise(strings)) -> strings;
enddefine;

define add_final_dot(strings) -> strings;
   lvars s i strings = maplist(strings, copy);
   /* Cope with entries which have annotations after main part. */
   for s in strings do
      if (locchar(10,2,s) ->> i)
      and (skipchar_back_all([32 9],i-1,s) ->> i) then
         `. -> s(i);
         return
      endif;
   endfor;
   for s in rev(strings) do
      if (skipchar_back_all([32 9],datalength(s),s) ->> i) then
         if s(i) = `)` do
            [^^strings '.'] -> strings
         else
            `. -> s(i);
         endif;
         return
      endif;
   endfor;
enddefine;


define has_initial_substring(str,substr);
   lvars str substr;
   isstring(str) and isstring(substr)
   and issubstring_lim(substr, 1,1,false, str) and true
enddefine;


define cond_substitute(item,test,substitution);
   lvars item test substitution;
   if item = test then substitution else item endif
enddefine;


define normal_initial(first_name);
   lvars first_name = first_name sys_>< '   ', s;
   if subscrs(1,first_name) == 92 then 3 else 1 endif -> s;
   consstring(lowertoupper(subscrs(s,first_name)), `., 2)
enddefine;

define locchars_back(chars,i,str);
   lvars i chars str;
   until i fi_<=1 do
      if fast_lmember(fast_subscrs(i,str), chars)
      and (i == 1 or fast_subscrs(i fi_- 1, str) /== `\\`) then
         return(i)
      endif;
      i fi_- 1 -> i;
   enduntil;
   false
enddefine;

define has_name_prefix(name) -> i;
   vars prefix prefixes = [' Van ' ' van ' ' de ' ' De ' ' du ' ' Du '], i;
   for prefix in prefixes do
      if issubstring(prefix,1,name) ->> i then return endif
   endfor;
enddefine;

define parse_name(name) -> initials -> surname;
   lvars name = substring(1, vedusedsize(name), name),de, s, n = datalength(name), initials surname;
   /* Try to cope with reversed name */
   skipchar(32,1,name) -> s;
   if issubstring_lim('The ',s,s,false,name) then
      ''-> initials; name -> surname; return
   endif;
   if (locchar(`,,1,name) ->> s)
   and not(locchars_back([32 46],s,name)) then
      substring(s + 1,n-s,name) >< ' '><  substring(1,s-1,name) -> name;
      datalength(name) -> n;
   endif;
   if (has_name_prefix(name) ->> s ->> de)
   or (locchars_back([%`., ` `%], n - 1, name) ->> s) then
      substring(s + 1, (n - s), name) -> surname;
      unless de do lowertoupper(surname(1)) -> surname(1) endunless;
      mapdata(substring(1,s,name), cond_substitute(%`.`, ` `%)) -> initials;
      ><_all(maplist(sysparse_string(initials), normal_initial)) -> initials;
   else
      name -> surname;
      '' -> initials;
   endif;
enddefine;


define normal_initials(name);
   lvars name initials surname;
   parse_name(name) -> initials -> surname;
   ><_all([^initials ' ' ^surname])
enddefine;

define put_normal_initials;
   maplist(normal_initials)
enddefine;

define rev_author_name(name);
   lvars name initials surname;
   parse_name(name) -> initials -> surname;
   surname >< ', ' >< initials
enddefine;

define sussex_fac_author_name(name) ->name;
   lvars name;
   lowertoupper(rev_author_name(name)) -> name;
enddefine;


define parse_names(name_string);
   lvars m, names, n = datalength(name_string), s name_string
        trigger triggers = ',' :: AND_strings, s = 0, start_s = 1,
        end_s;
   until s fi_>= n do
      s fi_+ 1 -> s;
      for trigger in triggers do
         if issubstring_lim(trigger,s,s,false,name_string)
         and locchars_back([32 `.],s,name_string) do
            skipchar_back(32,s fi_- 1,name_string) -> end_s;
            if start_s fi_< s then
               substring(start_s, (end_s - start_s) + 1, name_string);
            endif;
            datalength(trigger) -> m;
            s + m - 1 -> s;
            (skipchar(32,s + 1,name_string) or s) -> start_s;
            quitloop
         endif
      endfor;
   enduntil;
   unless start_s fi_>= n do
      substring(start_s, (n - start_s) + 1, name_string)
   endunless
enddefine;


define parse_name_fields;
   maplist(parse_names)
enddefine;


define app_author_names(strings, pdr) -> result;
   lvars strings, n = listlength(strings), names, pdr, name, result = [];
   maplist(strings, parse_names ) -> strings;
   if bib_initials_only then put_normal_initials(strings) -> strings endif;
   if listlength(strings) == 1 then
      conspair(pdr(hd(strings)), result) -> result;
   else
      for names on strings do
         if tl(names) == [] do
            conspair(bib_author_AND_string, result) -> result
         endif;
         pdr(hd(names)) -> name;
         conspair(name, result) -> result;
         unless tl(names) == [] do
            conspair(if tl(tl(names))==[] do ' ' else ', ' endif, result)
                  -> result
         endunless;
      endfor
   endif;
   ncrev(result) -> result;
enddefine;


define rev_author_names(strings) -> result;
   lvars strings result;
   app_author_names(strings, rev_author_name) -> result;
enddefine;


define format_author_names(strings);
   app_author_names(strings, identfn)
enddefine;


define sussex_fac_author_names;
   vars bib_author_AND_string = '& ';
   app_author_names(sussex_fac_author_name)
enddefine;

define has_AND(string);
   lvars s;
   for s in AND_strings do
      if issubstring(s, 1, string) then return(true) endif
   endfor;
   false
enddefine;


define add_eds(strings, eds, ed) -> strings;
   lvars eds, ed, string = hd(join_strings(strings)), strings;
   [% if has_AND(string) then
          string >< eds
       else
          string >< ed
       endif %] -> strings;
enddefine;


define add_default_eds;
   add_eds(' (Eds.)', ' (Ed.)')
enddefine;


define parse_date(strings) -> strings;
   capitalise(strings) -> strings;
enddefine;

define parse_date_year_only(strings);
   parse_date([%last(sysparse_string(last(strings)))%])
enddefine;

define put_pagenum_prefix(strings, p, pp) -> strings;
   lvars strings p pp;
   (if locchar(`-,1,strings(1)) then
      pp
   else
      p
   endif) >< strings(1) -> strings(1)
enddefine;


define put_default_pagenum_prefix;
   put_pagenum_prefix('p. ','pp. ')
enddefine;


define add_suitable_title_trim(strings);
   lvars string strings n m annotation = vednullstring, terminator = vednullstring;
   trim_line(hd(join_lines(strings))) -> string;
   datalength(string) -> n;
   if string(n) == `)` and (locchar(`(,1, string) ->> m) then
      substring(m, n-m+1, string) -> annotation;
      substring(1,m-1,string) -> string;
   endif;
   [% if current_target_spec == "roff" then
         '\\f2'; string; '\\f1' -> terminator
      elseif current_target_spec == "tex" then
         '\\it'; string; '\\rm' -> terminator;
      elseif current_target_spec == "lp" then
         lp_underline(string)
      elseif current_target_spec == "screen" then
         lowertoupper(string)
      else
         string
      endif, annotation, terminator %]
enddefine;


define get_bib_strings(strings_property);
   lvars strings = strings_property(current_target_spec);
   if islist(strings) then popval(strings) else explode(strings) endif
enddefine;


define add_finishing_touches(strings, pdr) -> strings;
   lvars pdr, substitution, strings string, v = bib_vert_spaces(current_target_spec);
   unless current_target_spec = "null" do
      add_final_dot(strings) -> strings;
   endunless;
   if current_target_spec == "roff" or current_target_spec == "tex" then
      fill_ref -> pdr
   elseif current_target_spec == "null" then
      identfn -> pdr
   endif;
   /* maplist(strings,
         do_splices(%[[',:' ':'][', (' ' (']['\\ ' ' ']['. (' ' (']
               ['..' '.']['\\0' ' ']]%)) -> strings; */
   for substitution in [[',:' ':'][', (' ' (']['\\ ' ' ']['. (p' ' (p']
      ['..' '.']['\\0' ' ']] do
         substitute_in(strings, substitution(1), substitution(2)) -> strings;
   endfor;
   [^^strings ^(get_bib_strings(bib_post_ref_strings))] -> strings;
   pdr(strings) -> strings;
   [^(get_bib_strings(bib_pre_ref_strings)) ^^strings
         ^(repeat v times '\t' endrepeat) ] -> strings;
enddefine;


define add_finish_justify;
   add_finishing_touches(justify_ref);
enddefine;


define add_finish_nofill;
   add_finishing_touches(identfn);
enddefine;

define add_finish_fill_tl;
   add_finishing_touches(justify_ref_tail)
enddefine;


/*
-- Processing bibtoolprog fields -------------------------------------
*/

define get_insert(filter, subscript);
   vars filter x result;
   if listlength(filter) >= subscript then
      recursive_valof(filter(subscript)) -> x;
      if isprocedure(x) do
         x()
      elseif isstring(x) do
         x
      elseif islist(x) then
         popval(x)
      endif
   endif;
enddefine;


define apply_pdr(pdr);
   if isword(pdr) and isprocedure(valof(pdr) ->> pdr)
   or isprocedure(pdr) do
      pdr()
   elseif islist(pdr) then
      popval(pdr)
   else
      identfn()
   endif;
enddefine;


define apply_subfunc(filter, subscript, strings) -> strings;
   vars pdr subscript string filter x =false;
   if not(islist(filter)) then
      apply_pdr(strings, filter) -> strings
   else
      if isinteger(subscript) and listlength(filter) >= subscript do
         apply_pdr(strings, filter(subscript)) -> strings;
      elseif not(isinteger(subscript)) do
         for pdr in filter do
            apply_pdr(strings, pdr) -> strings;
         endfor
      endif
   endif;
enddefine;


define has_key(key, field);
   vars right_key key field;
   if key.isvector then [% explode(key) %] -> key endif;
   if key.islist then
      key matches [== ?right_key:%has_key(%field%)% ==] and right_key
   else
      issubstring_lim(key,1,1,false,field)
      and key
   endif
enddefine;


define get_fields(key, remove_them, complete) -> strings;
   vars strings = [], found_key = false, actual_key, remove_them;
   lvars s isvec =isvector(fields), i = 0, temp_fields = fields,
         n = length(fields), complete;
   if isboolean(key) then key -> remove_them; -> key endif;
   until i fi_>= n or temp_fields == [] do
      i fi_+ 1 -> i;
      if isvec then
         fast_subscrv(i, fields)
      else
         destpair(temp_fields) -> temp_fields
      endif -> field;
      if (has_key(key, field) ->> actual_key) then
         actual_key ->> key -> found_key;
         if (skipchar(` `,datalength(key) fi_+ 1,field) ->> s) then
         if complete do field else substring(s,datalength(field)-s+1, field) endif
                  :: strings -> strings;
         endif;
      elseif found_key /* try to read overspill line */
      and subscrs(skipchar(` `,1,field) or 1 ->> s,
            field) /== `% then /* overspill line */
         (' '><(substring(s, (datalength(field) - s) + 1, field)))
               :: strings -> strings;
      elseif found_key then
         quitloop
      endif;
      if found_key and remove_them then
         ncdelete(field, fields, nonop ==) -> fields
      endif;
   enduntil;
   ncrev(strings) -> strings;
   /* if strings == [] then fields ==> endif; */
enddefine;

define get_filter(key, filters);
   lvars filter filters filter_key;
   fast_for filter in filters do
      if isstring(hd(filter) ->> filter_key)
      and substr(key, 1, filter_key) then
         return(filter)
      endif
   endfor;
   false
enddefine;

define apply_filter(filter, strings) -> strings;
   lvars filter strings;
   [%  get_insert(filter, 3);
       dl(apply_subfunc(filter, 2, strings));
       get_insert(filter, 4) %] -> strings;
   apply_subfunc(filter, 5, strings) -> strings;
enddefine;

/*
-- Processing references --------------------------------------------
*/

/* Cope with the fact that the UNIX refer spec. allows you to
use either %B or %T for an emphasisable title. */
define pre_process_raw_ref(fields) -> fields;
   lvars list fields;
   if get_fields('%T', false, true)/== []
   and get_fields('%B', false, true) == []
   and get_fields('%J', false, true) == [] then /* Do desctructive update */
      get_fields('%T', false, true) -> list;
      `B -> hd(list)(2);
   endif;
enddefine;

define set_bib_ref_type(fields);
   lvars strings;
   if (get_fields('%B',false,true) ->> strings) /== [] then
      if issubstring('roceedings',1, strings(1)) then
         "p"
      elseif get_fields('%T', false,true) /== [] then
         "c"
      else
         "b"
      endif
   elseif get_fields('%J', false,true) /== [] then
      "j"
   else
      undef
   endif -> bib_ref_type;
enddefine;

define process_raw_ref(fields) -> strings;
   vars key pdr filter field;
   lvars strings, subscript after_pdr = false, default_filter
        filters, alternative_filters, m filter_list, last_key, fail_count = 0;
   /* Fields are a vector; convert. */
   [% explode(fields) %]-> fields;
   set_bib_ref_type(fields);
   apply_pdr(fields, current_program(Pre_process_fields)) -> fields;
   current_program(Filters) -> filters;
   if filters == [] then fields -> strings; goto finish; endif;
   current_program(Default_filter) -> default_filter;
   listlength(default_filter) -> m;
   pre_process_raw_ref(fields) -> fields;
   get_fields('%X', true, false) -> bib_X_field_strings;
   get_fields('%K', true, false) -> bib_K_field_strings;
   [% until fields == []
      or fail_count > 5 do
          if filters /== [] do
             fast_destpair(filters) -> filters
          else
             default_filter
          endif -> filter;
newfilter:
       nextunless(ispair(filter));
          hd(filter) -> key;
          unless islist(key) or isstring(key) or isvector(key) do
             popval(filter) -> filter;
             goto newfilter;
          endunless;
          /* cope with case where filter is a list of filters */
          if key.islist then filter else [^filter] endif -> filter_list;
          for filter in filter_list do
             filter(1) -> key;
             add_defaults(filter, default_filter) -> filter;
             listlength(filter) -> n;
             if (get_fields(key, true, false) ->> strings) /== [] do
                dl(apply_filter(filter, strings));
                0 -> fail_count;
                quitloop
             else
               if key = last_key then fail_count + 1 -> fail_count; endif;
               key -> last_key;
             endif;
          endfor;
       enduntil %] -> strings;
finish:
   apply_pdr(strings, current_program(Post_process_fields)) -> strings;
   {% dl(strings) %} -> strings;
enddefine;

define process_bib(bib) -> bib;
   /* bibjob_message('Processing references'); */
   if bib_sort_strategy then sort_bib(bib) -> bib endif;
   apply_pdr(bib, current_program(Pre_process_bib)) -> bib;
   [% applist(bib, process_raw_ref) %] -> bib;
   apply_pdr(bib, current_program(Post_process_bib)) -> bib;
enddefine;

/*
-- Dealing with raw-form references ---------------------------------
*/

define get_author_names -> names;
   lvars names key;
   for key in ['%A' '%E' '%Q' '%J' '%I'] do
      quitif((get_fields(key, false, false) ->> names) /== []);
   endfor;
   maplist(names, parse_names) -> names;
   if names == [] do
      ['A. DUMMY_NAME'] -> names;
      /* mishap('Ref with no author names', [^fields]) */
   endif;
enddefine;

define get_author_names_from(fields);
   maplist(get_author_names(), parse_name pdcomp erase)
enddefine;

define get_date -> date;
   if (get_fields('%D', false, false) ->> date) /== [] do
      ''><(last(sysparse_string(hd(date))))
   else
      '2001'
   endif -> date;
enddefine;

define parse_raw_bib(data);
   lvars fields_vec, i, n = datalength(data), entry_length = 0, start = 1, line;
      [% fast_for i from 1 to n fi_+ 1 do
             if (i fi_> n or (fast_subscrv(i, data) ->> line) = '')
             and entry_length fi_> 1 then
                move_subvector(start, data, 1, initv(entry_length)
                     ->> fields_vec, entry_length);
                fields_vec;
                /* mapdata(fields_vec, uppertolower_ref_string);*/
                false -> start;
                0 -> entry_length;
             elseif line /= '' then
                if not(start) then i -> start endif;
                entry_length + 1 -> entry_length;
             endif;
          endfor %];
enddefine;

define derive_raw_ref_citations(raw_refs, flag);
   lvars fields_vec raw_refs names initials surname date flag
         citation names_list many_names n;
   vars fields;
   [% for fields_vec in raw_refs do
         conslist(destvector(fields_vec)) -> fields;
         [%    if flag="date" do [] else get_author_names() endif-> names_list;
               listlength(names_list) -> n;
               unless flag do [%hd(names_list)%] -> names_list endunless;
               cons_with consstring {%
                  for names on names_list do
                     hd(names) -> citation;
                     parse_name(citation) -> initials -> surname;
                     if flag then
                        explode(surname);
                     else
                        explode(surname); explode(initials);
                     endif;
                     if flag == "no_punctuation" do
                        ` `
                     elseif flag then
                       if (n-1 ->> n)==1 do explode(' and ') else `,,` ` endif
                     endif;
                  endfor;
                  explode(get_date());
                  %} -> citation;
               fields_vec; citation %];
       endfor %]
enddefine;

/*
-- Setting up the "current" vars ------------------------------------
*/

define assign_core_to_current;
   core_input -> current_input;
   core_citations_map -> current_citations_map;
enddefine;

define assimilate_new_ref(fields, citations_map);
   vars names a;
   maplist(get_author_names(), parse_name pdcomp erase) -> names;
   uppertolower(consword(hd(sysparse_string(hd(names))))) -> a;
   fields :: citations_map(a) -> citations_map(a);
enddefine;

define derive_citations_map(data) -> map;
   lvars refs, data map = newproperty([],16,[],true); vars fields;
   if data == core_input and core_citations_map.isproperty then
      core_citations_map -> map
   else
      /* bibjob_message('Reading bibliography'); */
      parse_raw_bib(data) -> refs;
      bibjob_message(length(refs)><' references read');
      applist(refs, assimilate_new_ref(%map%));
   endif;
enddefine;

define get_current_bib;
   [% appproperty(current_citations_map,
            procedure(a,f); dl(f) endprocedure) %]
enddefine;

define new_core_bib_ref;
   assimilate_new_ref(core_citations_map);
enddefine;


define get_core_authors;
   [% appproperty(core_citations_map, erase) %]
enddefine;

define set_core_authors;
   get_core_authors() -> bib_core_authors;
enddefine;


/*
-- Sortbib ----------------------------------------------------------
*/

define sort_bib(bib) -> bib;
   lvars strat = bib_sort_strategy, flag; vars names fields bib fields_vec pdr;
   nodups(bib) -> bib;
   if member(strat, [date reverse_date]) do "date" else false endif -> flag;
   derive_raw_ref_citations(bib, flag) ->> bib -> it;
   if strat = "reverse_date" do alphabefore <> not else alphabefore endif -> pdr;
   syssort(bib, false,
         procedure(x,y); pdr(uppertolower(x(2)),
               uppertolower(y(2))) endprocedure)
               -> bib;
   maplist(bib, hd) -> bib;
enddefine;


/*
-- Addbib -----------------------------------------------------------
*/

define bib_update_from_raw_ref(raw_ref, bibname);
   write_buffers([%{^vednullstring}<>raw_ref%], bibname, sysopen);
   if bibname = corebibname then new_core_bib_ref(raw_ref); endif;
enddefine;

define convert_addbib_buffer -> vedbuffer;
   vars s t vedediting = false, vedbuffer = mapdata(vedbuffer, copy);
   vedbufferextend();
   foreach [?s ?t] in addbib_mapping do veddo('gs /'><s><'/'><t) endforeach;
   {% appdata(vedbuffer,
          procedure(l); if vedusedsize(l) > 2 do l endif; endprocedure) %}
      -> vedbuffer;
enddefine;

define ved_addbib;
   lvars file_struc n i buffer;
   if vedargument /= vednullstring do vedargument -> corebibname; endif;
   run_time_setup();
   do_core_check();
   if vedcurrent /= addbib_file then
      vedopen(addbib_file,
         procedure; false -> vedbreak; vedhelpdefaults(); endprocedure);
         -> file_struc;
      {% explode(maplist(addbib_mapping, hd)) %} -> file_struc(3);
      vedsetonscreen(file_struc, 'Fill in the appropriate fields');
   else
      invisible_ved_apply(convert_addbib_buffer, vedbuffer) -> buffer;
      vedput_processed_bib(%[% process_raw_ref(hd(parse_raw_bib(buffer)))%]%)
      :: ved_char_in_stream -> ved_char_in_stream;
      bib_update_from_raw_ref(buffer, corebibname);
      ved_q();
      sysdelete(addbib_file) ->;
      set_core_authors();
   endif;
enddefine;



/*
-- Lookbib ----------------------------------------------------------
*/

define same_char(c1,c2);
   lvars c1 c2 d;
   c1 == c2 or
   (c1 fi_- c2 -> d, d fi_* d == 1024)
enddefine;

define ci_issubstring(sub,i,str);
    lvars i = i fi_-1,j,sub, str, n = datalength(str), m = datalength(sub), limit = n fi_-m;
    until i fi_> limit do
        i fi_+ 1 -> i;
        if same_char(fast_subscrs(1,sub),fast_subscrs(i,str)) then
            0 -> j;
            until j fi_>= m do
                nextunless(same_char(fast_subscrs(j fi_+ 1,sub),
                    fast_subscrs(i fi_+ j,str)))(2);
                j fi_+ 1 -> j;
            enduntil;
            return(i);
        endif;
    enduntil;
    return(false);
 enddefine;


define collect_fields(keys, fields) -> n;
   lvars field fields key keys i j, n = 0;
   [% explode(keys) %] -> keys;
   for i from 1 to datalength(fields) do
      fast_subscrv(i, fields) -> field;
      for key in keys do
         if fast_subscrs(1,key) == `% then 3 else 1 endif -> j;
         if ci_issubstring(key,j,field) then
            n fi_+ 1 -> n;
            ncdelete(key, keys, nonop ==) -> keys;
            nextloop
         endif;
      endfor;
   endfor;
enddefine;


define look(strings, refs) -> result;
   lvars rf refs strings, n = listlength(strings), m, result;
   vars ci_issubstring = (bib_ignore_case and ci_issubstring or issubstring);
   if refs /== [] do
      [% for rf in refs do
            if collect_fields(strings, rf) fi_>= n do rf endif
         endfor %] -> result;
      if result == [] then false -> result endif;
   endif;
enddefine;

define raw_ref_from_map(strings);
   return(current_citations_map(uppertolower(consword(hd(strings)))))
enddefine;

define look_non_indexed_bib(strings, bib) -> result;
   vars current_citations_map result;
   lvars strings references;
   if bib = corebibname
   and core_citations_map.isproperty
   and not_core_citation /== true do
      core_citations_map
   else
      derive_citations_map(bibreadin(bib))
   endif -> current_citations_map;
   unless not(bib_lookall)
   and (raw_ref_from_map(strings) ->> references) /==[]
   and (look(strings, references) ->> result) do
      look(strings, get_current_bib()) -> result;
   endunless;
enddefine;

define fileparse(file) -> host -> file;
   lvars host = false, file, i;
   if (locchar(`:, 1, file) ->> i) then
      substring(1, i - 1, file) -> host;
      substring(i + 1, datalength(file) - i, file)
         -> file;
   else
      false -> file;
   endif;
enddefine;


define look_indexed_bib(strings, bib) -> result;
   vars com h, host = 'csuna', input;
   if fileparse(bib) ->> h do -> bib, h -> host else -> endif;
   ;;; delete('al', delete('et', strings)) -> strings;
   'rsh ' >< host ><' "tr A-Z a-z | /usr/lib/refer/hunt -l 5000" ' ><bib -> com;
   ;;;'rsh ' >< host ><' "tr A-Z a-z | /usr/lib/refer/hunt" ' ><bib -> com;
   sysobey_output([{%hd(join_lines(strings))%}], com) -> input;
   parse_raw_bib(bibreadin(input)) -> result;
   if result == [] then false -> result endif;
enddefine;


define remove_file_type(file);
   lvars file;
   substring(1, datalength(file) - 2, file)
enddefine;


define try_look_bib(strings, bib);
   bibjob_message('LOOKBIB ('><(bib=corebibname and '' or bib)><') '>< strings);
   vars bibjob_message = erase;
   if strings == [] then return(false) endif;
   if sysfiletype(bib) = 'i' then
      look_indexed_bib(strings, remove_file_type(bib))
   else
      look_non_indexed_bib(strings, bib)
   endif;
enddefine;

define parse_cit(cit);
   dlocal %item_chartype(`-`)% = 1, %item_chartype(`.`)% = 1, %item_chartype(`'`)% = 1;
   lvars item, rep = incharitem(stringin(cit));
   [ % until (rep() ->> item) == termin do item sys_>< '' enduntil %]
enddefine;

define lookbib(citations);
   lvars i strings refs citations citation;
   vars not_core_citation bib_lookall bib_bad_citations = [];
   unless ispair(bibsearchlist) and isstring(hd(bibsearchlist)) do return([]) endunless;
   [% for i from 1 to length(citations) do
          parse_cit(citations(i)) -> strings;
          nextif(strings == []);
          splice_out_all(strings, bib_citation_punctuation_strings) -> strings;
          for bib in bibsearchlist do
             quitif((try_look_bib(strings, bib) ->> refs)
             and not(bib_lookall) and (bib ->> lookbib_found));
             if refs then explode(refs)
             else
                [1 ^strings] :: bib_bad_citations -> bib_bad_citations;
             endif;
          endfor;
          if refs then explode(refs) endif;
       endfor %]
enddefine;


/* This is an old version of -look_indexed_bib-. It includes a hard-won
command construction for rsh-ing a lookbib!

define no_list_brackets(x) -> x;
   lvars x;
   x><'' -> x,
   substring(2, datalength(x) -2, x) -> x;
enddefine;

define OLD_look_bib(strings);
   vars com i corebibname, host = 'csuna', tmpfile ;

   if (locchar(`:, 1, corebibname) ->> i) then
      substring(1, i - 1, corebibname) -> host;
      substring(i + 1, datalength(corebibname) - i, corebibname)
            -> corebibname;
   endif;
   delete('al', delete('et', strings)) -> strings;
   if sysfiletype(corebibname) = 'i' then
      if using_scratch_file then systmpfile(false, '','') else scratch_file endif
            ->> tmpfile -> using_scratch_file;
      ><_all([%
            'rsh ', host, ' "lookbib ',
            sysfiledir(corebibname) dir_>< sysfilename(corebibname),
            '" \\>\\& ', tmpfile,
            ' << foo \n\n ', no_list_brackets(strings),
            '\nfoo' %]) -> com;
   else
      return(false)
   endif;
   com -> y;
   sysobey(com);
   parse_raw_bib(bibreadin(tmpfile));
   not(tmpfile = using_scratch_file) -> using_scratch_file;
   sysdelete(tmpfile) ->;
enddefine; */

/*
-- Refer ------------------------------------------------------------
*/

define issubstringall(patterns, index, string);
   lvars pattern patterns big_val = 99999, string, min_i = big_val, index;
   for pattern in patterns do
      if (issubstring(pattern, index, string) ->> i) then
         if i < min_i do i -> min_i endif
      endif;
   endfor;
   return(min_i /== big_val and min_i);
enddefine;


define vedtestsearchall(patterns);
   lvars pattern patterns min_i i line n = vedusedsize(vedbuffer);
   vedpositionpush();
   until vedatend() do
      if issubstringall(patterns, vedcolumn, vedthisline()) ->> min_i then
         min_i -> vedcolumn;
         return(vedthisline())
      else
         vednextline();
      endif
   enduntil;
   vedpositionpop();
   false
enddefine;

define isdate(string);
   lvars date;
   string = 'forthcoming'
   or ((strnumber(string sys_>< '') ->> date)
   and isinteger(date) and date > 1000 and date < 2020)
enddefine;

define scan_back_for_author_names(authors);
   vars line = vedline, vedline, vedcolumn, item, ok, list;
   until (line - vedline > 0 and (vedchardown(), vedthisline() = vednullstring, vedcharup()))
   or line - vedline > 4 do
      if fast_member(uppertolower(vedmovebackitem()), authors) then
         vedmoveitem() ->;
         [% while (fast_member(uppertolower(vedmovebackitem() ->> item),
                  authors) ->> ok)
            or fast_member(item><'', bib_citation_punctuation_strings) do
               if ok then item endif;
            endwhile %] -> list;
         return(rev(list))
      endif
   enduntil;
   return(false);
enddefine;

define get_popversion; strnumber(substring(10,2,popversion)) enddefine;

vars vedgetchartype =
   procedure(c,v);
      if c == `- or c == `. or c == `' then `a else v(c) endif
   endprocedure(%vedchartype%);

define ved_get_citation(vedcolumn) -> date_only -> cit_start_pos -> cit_end_pos -> citation;
   lvars pos date citation = false, cit_end_pos c item string date_only;
   vars vedcolumn vedline vvedlinesize, vedchartype = vedgetchartype;
   #_IF get_popversion() >= 13
   dlocal %item_chartype(`-`)% = 1, %item_chartype(`.`)% = 1, %item_chartype(`'`)% = 1;
   #_ENDIF
   {%vedline, vedcolumn%} -> pos;
   /* Pick up date. */
   vedcurrentitem()><'' -> date;
   if isdate(date) then
      vedmoveitem() ->;
      [%date><''%] -> citation;
      {%vedline, vedcolumn - 1%} -> cit_end_pos;
   else
      return  /* citation is false */
   endif;
   explode(pos) -> vedcolumn -> vedline;
   ;;;vedmovebackitem() ->; vedcharright();
   repeat
      quitif(vedatstart());
      vedcharleft();
      if not(skipchar(` `,1,vedthisline())) /* blank line */
      or (vedline fi_< (fast_subscrv(1, cit_end_pos) - 3)) then
         /* Cannot be a valid citation. */
         ;;;(vedline :: citation) :: bib_bad_citations -> bib_bad_citations;
         explode(cit_end_pos) -> vedcolumn -> vedline;
         false -> citation;
         return
      endif;
      nextunless(vedcurrentchar() /=` ` and
         vedatitemstart(vedcolumn, vedthisline(), vvedlinesize));
      (vednextitem())><'' -> item;
      quitif(fast_member(item, bib_open_brackets) or
         (isdate(item) and vedmoveitem()));
      unless fast_member(item, bib_citation_punctuation_strings) do
         conspair(item, citation)-> citation;
      endunless;
   endrepeat;
   vedmoveitem() ->; /* Move back to the start of the citation. */
   /* Move past any back slashes */
   if vedmoveitem() /= "\" do vedmovebackitem() -> endif;
   while vedcurrentchar() == 32 do vedwordright() endwhile;
   {%vedline, vedcolumn%} -> cit_start_pos;
   if (listlength(citation) == 1 ->> date_only) /* author-less citation */
   and (scan_back_for_author_names(bib_core_authors) ->> string) then
      string <> citation -> citation;
   endif;
enddefine;


define ved_get_cit_data -> cit_locs -> bib_entries -> citations;
   lvars citation_bibloc cit_locs last_cit = false, bib_entries cit_loc
        cit_vec entry cit_end_pos citation;
   vars date_only ibid_able;
   newproperty([],16,[],false) -> citation_bibloc;
   [] ->> cit_locs ->> bib_bad_citations ->> bib_good_citations -> bib_entries;
   [] ->> bib_refs_cited -> citations;
   1 ->> vedline -> vedcolumn;
   while vedtestsearchall(bib_ref_centuries) do
      ved_get_citation(vedcolumn) ->date_only ->cit_start_pos
            ->cit_end_pos -> citation;
      if not(citation) then
         vedwordright()
      else
         explode(cit_end_pos) -> vedcolumn -> vedline;
         if (lookbib({%hd(join_lines(citation))%}) ->> entry) /== [] then
            hd(entry) :: bib_refs_cited -> bib_refs_cited;
            /* Record where the reference was found */
            citation :: citation_bibloc(consword(lookbib_found))
               -> citation_bibloc(consword(lookbib_found));
         {% hd(join_lines(citation)) %} :: citations -> citations;
            if tl(entry) == [] then
               citation :: bib_good_citations -> bib_good_citations
            else
               (vedline :: citation) :: bib_bad_citations -> bib_bad_citations
            endif;
            hd(entry) -> entry;
            if entry isin bib_entries do
               it -> entry;
            else /* Make sure no destructive assignments. */
               copy(entry) -> entry;
               entry :: bib_entries -> bib_entries
            endif;
            (last_cit and entry = last_cit(3)
            and cit_end_pos(1) - last_cit(2)(1) < bib_ibid_limit) -> ibid_able;
            ([^cit_start_pos ^cit_end_pos ^entry ^date_only ^ibid_able]
                  ->> last_cit) :: cit_locs -> cit_locs;
         else
            [^vedline ^citation] :: bib_bad_citations -> bib_bad_citations;
         endif;
      endif
   endwhile;
   bibjob_message('Found: '><listlength(cit_locs) ><' citations, '><
      listlength(bib_bad_citations) >< ' bad citations');
enddefine;

define derive_num_citations(raw_refs);
   lvars i;
   newassoc(
      [% for i from 1 to listlength(raw_refs) do
         [%destpair(raw_refs) -> raw_refs, i%]
      endfor %])
enddefine;


define derive_full_citations(raw_refs);
   vars citations rest_tags char field new_tag citation fields; lvars i;
   derive_raw_ref_citations(raw_refs, true) -> citations;
   [% until citations == [] do
          hd(citations)(2) -> citation;
          if [= ^citation] isin tl(citations) then
             `a -> char;
             foreach [?fields ^citation] in citations do
                /* Delete then update it. */
                delete(it, citations) -> citations;
                citation >< consstring(char,1) -> new_tag;
                for i from 1 to datalength(fields) do
                   if issubstring('%D',1,fields(i)) then
                      fields(i) >< consstring(char, 1) -> fields(i);
                      quitloop
                   endif
                endfor;
                [^fields ^new_tag];
                char + 1 -> char;
             endforeach;
          else
             hd(citations);
             quitif(citations == []);
             back(citations) -> citations;
          endif;
       enduntil %].newassoc;
enddefine;


define buffer_splice(buffer, start_pos, end_pos, strings) -> new_buffer;
   lvars start_length = start_y, buffer y end_y end_x line n start_y start_x buffer_length new_buffer end_length strings_length string i;
   datalength(buffer) -> buffer_length;
   explode(end_pos) -> end_x -> end_y;
   (vedusedsize(buffer) - end_y) + 1 -> end_length;
   explode(start_pos) -> start_x -> start_y;
   if (start_y + end_length ->> n) < buffer_length do
      buffer;
   else
      fill(repeat n times vednullstring endrepeat, initv(n))
   endif -> new_buffer;
   hd(join_strings([%
             substring(1, start_x - 1, buffer(start_y));
             explode(strings);
             datalength(buffer(end_y) ->> line) -> n;
             if end_x fi_< n then
                substring(end_x + 1,
                   fi_max(0, datalength(line) - end_x), line);
             endif;
             %])) -> string;
   move_subvector(1, buffer, 1, new_buffer, start_y - 1);
   move_subvector(end_y + 1, buffer, start_y + 1, new_buffer,
      end_length  - 1);
   string -> new_buffer(start_y);
   for y from start_y + end_length to buffer_length do
      vednullstring -> fast_subscrv(y, new_buffer);
   endfor;
enddefine;


vars bib_index_keys = ['CONTENTS_INDEX' 'AUTHOR_INDEX'
   'GENERAL_INDEX' 'SUBJECT_INDEX' 'FIGURES_INDEX' 'END_INDEX'
   'CHAPTER' 'REFERENCES' 'AUTHOR INDEX' 'SUBJECT INDEX'];

define line_starts_with(line, key);
   lvars line j key;
  (skipchar(` `,1,line) ->> j)
  and issubstring_lim(key, j, j, false, line)
enddefine;


define line_starts_with_any(line, keys);
   lvars key keys;
   for key in keys do
      if line_starts_with(line, key) then return(true) endif
   endfor;
   false
enddefine;


define not_nullstring(line);
   lvars i;
   (skipchar(` `,1,line) ->> i)
   and vedusedsize(line) - i fi_> 20
enddefine;

define parse_index_entry(line) -> name -> num;
   lvars line m = datalength(line), j k name num;
   substring(skipchar(32,1,line) or 1 ->> j, m - j + 1, line) -> line;
   datalength(line) -> m;
      unless ((issubstring('..', 1, line) ->> j) and j - 1 ->> j)
   and (locchar_back(32, m, line) ->> k)
   and k > j
   and j fi_> 1
   and (substring(1, skipchar_back(32,j - 1,line) or j - 1, line) ->> name)
   and (strnumber(substring(k + 1, m-k,line) ->> num)) do
      false ->> name -> num
   endunless;
enddefine;

define get_entries(start_key, end_keys, buffer);
   lvars start_key, end_keys, file, filter, buffer i = 0, n = datalength(buffer),
         name, num, line, lines = [], start_key_length = datalength(start_key), j start_line;
   delete(start_key, end_keys) -> end_keys;
   until i fi_>= n do
      i fi_+ 1 -> i;
      fast_subscrv(i, buffer) -> line;
      if line_starts_with(line, start_key) then
         i -> start_line;
         vednullstring :: lines -> lines;
         until line_starts_with_any(line, end_keys) do
            if not_nullstring(line) do conspair(line, lines) -> lines endif;
            i fi_+ 1 -> i;
            quitif(i fi_> n)(2);
            fast_subscrv(i, buffer) -> line;
         enduntil;
         move_subvector(i, buffer, start_line, buffer, n - i + 1);
         for j from (n - (i - start_line)) + 1 to n do
            vednullstring -> fast_subscrv(j, buffer)
         endfor;
         vedusedsize(buffer) -> n;
      endif;
   enduntil;
   return(ncrev(lines));
enddefine;

define buffer_extract(start_key, file, pdr, key_string, buffer);
   lvars entries;
   unless file do return endunless;
   get_entries(start_key, bib_index_keys, buffer) -> entries;
   if delete(vednullstring, entries) /= [] do
      pdr(entries) -> entries;
      write_buffers([{% explode(entries) %} ], file, sysopen);
   endif;
enddefine;

define initial_string(str);
   lvars c i = 1, n = datalength(str), type = vedchartype(str(1));
   cons_with consstring
   {% while i fi_<= n
       and vedchartype(str(i) ->> c) == type do
          c; i + 1 -> i
       endwhile %}
enddefine;

define format_index(lines);
   lvars contents num, line s s1 lines entry current = 0, name; vars key_string;
   [% '.bp'; '.nf'; '.ce 1'; key_string; vednullstring;
       if (key_string = 'CONTENTS' ->> contents) then '.in 0.25i' endif;
       for line in lines do
       nextif(line = '');
          if (parse_index_entry(line) -> name ->> num) then
             name ><
                  (if isalphacode(last(name)) or isnumbercode(last(name)) do
                     ',   '
                  else
                     '   '
                  endif) >< num -> entry;
             uppertolower(initial_string(name) ->> s) -> s1;
             if ((s1 = 'chapter' or s1 = 'appendix')
                and (not(false ->> current ->> s))) /* suppress next trigger*/
             or current and s /= current then
                if s then s -> current endif;
                if contents then
                   '.sp 2'; '.ne 4'; '.ti 0'; '.ul 1'; entry; '.sp 1';
                else
                   '.sp 1'; entry;
                endif
             else
                /* if contents then entry else line endif; */
                entry
             endif;
          endif
       endfor;
       '.fi' %]
enddefine;

/* Invert an index made up of 'xxxxx ............ <line-num>' entries. */
define invert_index(lines) -> lines;
   lvars initial_char = 0, pagenums = newproperty([],16,[],true), line
        lines j m k word num i;
   vars key_string;

   define isbefore(x,y);
      alphabefore(uppertolower(x), uppertolower(y))
   enddefine;

   for line in lines do
      if (parse_index_entry(line) -> word ->> num)
      and not(lmember(strnumber(num) ->> num,
               pagenums(consword(word) ->> word))) do
         num :: pagenums(word) -> pagenums(word)
      endif
   endfor;
   datalist(pagenums) -> pagenums;
   if pagenums == [] then [] -> lines, return endif;
   syssort(pagenums, procedure(x,y); isbefore(hd(x), hd(y)) endprocedure) -> pagenums;
   [ %'.bp'; '.ce 1'; key_string; vednullstring; '.sp 3';
      '.2c'; '.in 0.5i'; '.xl -0.5i';
       applist(pagenums,
          procedure(couple);
             vars word nums;
             couple(1) -> word; sort(nodups(couple(2))) -> nums;
             if uppertolower(word(1)) /== initial_char do
                uppertolower(word(1)) -> initial_char;
                vednullstring; vednullstring;
             endif;
             '.ti 0'; '.br';
             maplist(nums, procedure(n); ', '><n endprocedure) -> nums;
             hd(join_strings(word :: nums));
          endprocedure); '.in -0.5i'; '.xl +0.5i'; '.1c' %] -> lines;
enddefine;


define extract_indexes(buffer, files);
   lvars files;
   applist(files, procedure(f); if f then sysdelete(f) -> endif endprocedure);
   buffer_extract('CONTENTS_INDEX', files(1), format_index, 'CONTENTS', buffer);
   buffer_extract('FIGURES_INDEX', files(2), format_index, 'LIST OF FIGURES', buffer);
   buffer_extract('AUTHOR_INDEX', files(3), invert_index, 'AUTHOR INDEX', buffer);
   buffer_extract('SUBJECT_INDEX', files(4), invert_index, 'SUBJECT INDEX', buffer);
   buffer_extract('GENERAL_INDEX', files(5), invert_index, 'INDEX', buffer);
enddefine;


define delete_blanks(buffer);
   lvars coords_list coords y = 0, n = datalength(buffer), line i n k j str;
   until y fi_>= n do
      y fi_+ 1 -> y;
      fast_subscrv(y, buffer) -> line;
      0 -> i;
      while (locchar(0,i fi_+ 1,line) ->> i) do
         if (locchar_back(`],i,line) ->> j) do
            substring(1,j,line) ><
                  substring(i fi_+ 1, datalength(line) fi_- i, line)
         else
            substring(skipchar(32, i fi_+ 1, line) or i ->> i,
                  datalength(line) fi_- i, line);
         endif ->> line -> fast_subscrv(y, buffer);
      endwhile;
   enduntil;
enddefine;


/* Change '....[1][2]...' into '...[1,2]...' */
define merge_num_citations(buffer);
   lvars coords_list coords y = 0, next, m = datalength(buffer),
         line i n k j str;
   until y fi_>= m do
      y fi_+ 1 -> y;
      fast_subscrv(y, buffer) -> line;
      vedusedsize(line) -> n;
      0 -> i;
      while (locchar(`],i fi_+ 1,line) ->> i) do
         if i fi_< n
         and subscrs(i fi_+ 1, line) == `[ then
            splice(line, '][', ',') ->> line -> fast_subscrv(y, buffer);
            vedusedsize(line) -> n;
         /* check for line-end case */
         elseif i == n
         and y fi_< m
         and datalength(fast_subscrv(y fi_+ 1, buffer) ->> next) fi_>= 3
         and subscrs(1, next) == `[ then
            nextunless(locchar_back(`[,i,line) ->> j);
            ><_all([% substring(j,i - j,line), ',',
                  substring(2, datalength(next) fi_- 1, next) %])
                  -> fast_subscrv(y fi_+ 1, buffer);
            set_bytes(32,j,line, i - j + 1);
         endif;
      endwhile;
   enduntil;
enddefine;


define put_et_al(tag) -> tag;
   lvars tag rep item new_tag abbreviation;
   if current_target_spec == "roff" do
      ['\\f2et al.\\f1,']
   elseif current_target_spec == "tex" then
      ['\\it et al., \\rm']
   else
      ['et al.,']
   endif -> abbreviation;
   incharitem(stringin(tag)) -> rep;
   [% until (rep() ->> item) == termin do item enduntil %] -> new_tag;
   if listlength(new_tag) fi_> 5 do
      ><_all([%hd(new_tag), dl(abbreviation), last(new_tag)%], true) -> tag
   endif;
enddefine;

define date_only_tag(tag);
   lvars tag = tag sys_>< '', n = datalength(tag);
   if n > 4 then substring(n - 3,4,tag) else tag endif
enddefine;

define ibid_tag(tag);
   if current_target_spec == "roff" then
      '\\f2ibid.\\f1'
   elseif current_target_spec == "tex" then
      '\\it ibid. \\rm'
   else
      'ibid.'
   endif
enddefine;

define foobaz -> x;
   invisible_ved_apply(ved_get_cit_data, vedbuffer) -> x -> ->;
enddefine;

define make_bib(buffer);
   lvars raw_refs;
   invisible_ved_apply(ved_get_cit_data,buffer) -> -> raw_refs ->;
   [% {%get_bib_strings(bib_pre_bib_strings)%};
         {%bib_bibliography_title%};{%vednullstring%};
         dl(process_bib(raw_refs));
      {% get_bib_strings(bib_post_bib_strings)%} %];
enddefine;


define process_citations(buffer, derive_tags) -> buffer -> raw_refs;
   lvars citations citation raw_ref_map tag n;
   vars start_pos end_pos raw_ref date_only ibid_able;
   copy(buffer) -> buffer;
   invisible_ved_apply(ved_get_cit_data,true,buffer) -> citations -> raw_refs ->;
   if bib_sort_strategy do sort_bib(raw_refs) else rev(raw_refs) endif -> raw_refs;
   derive_tags(raw_refs) -> raw_ref_map;
   for citation in citations do
      citation --> [?start_pos ?end_pos ?raw_ref ?date_only ?ibid_able];
      raw_ref_map(raw_ref) -> tag;
      if derive_tags == derive_full_citations and bib_et_al_abbreviate do
         put_et_al(tag) -> tag;
      endif;
      if iscaller(full_refer) then
         if date_only do date_only_tag(tag) -> tag endif;
         if bib_ibid_abbreviate and ibid_able do ibid_tag(tag) -> tag endif;
      endif;
      buffer_splice(buffer, start_pos, end_pos, {% tag %}) -> buffer;
   endfor;
   vedusedsize(buffer) -> n;
   move_subvector(1, buffer, 1, initv(n) ->> buffer, n);
enddefine;

define full_refer(buffer) -> buffer;
   lvars buffer raw_refs refs, do_process_bib = true;
   if isboolean(buffer) then buffer -> do_process_bib; -> buffer; endif;
   process_citations(buffer, derive_full_citations) -> buffer -> raw_refs;
   if do_process_bib then
      {% get_bib_strings(bib_pre_bib_strings);
          bib_bibliography_title; vednullstring;
          applist(process_bib(raw_refs), explode);
          get_bib_strings(bib_post_bib_strings) %} -> refs;
      insert_refs(refs, buffer) -> buffer;
      delete_blanks(buffer);
      [^buffer] -> buffer;
   endif;
enddefine;

define modify_raw_ref(raw_ref, ref_tail) -> raw_ref;
   lvars i j n = datalength(ref_tail),  raw_ref; vars x a b;
   [% explode(raw_ref) %] -> raw_ref;
   if ((issubstring(' p. ',1,ref_tail) ->> i)
      or (issubstring('pp.',1,ref_tail) ->> i ))
   and (i fi_+ 4 ->> i ->> j) do
      until j fi_>= n or not(isnumbercode(ref_tail(j))) do j fi_+ 1 -> j enduntil;
      if raw_ref matches [??a ?x:%has_initial_substring(%'%P'%)% ??b] then
         {% explode(a), '%P  '><substring(i, j-i + 1, ref_tail), explode(b) %} -> raw_ref;
         return
      endif
   endif
enddefine;

define insert_refs(refs, buffer);
   lvars i = 1,n = vedusedsize(buffer), buf1, buf2 = {};
   until i fi_> n do
      quitif(issubstring_lim('REFERENCES_HERE',1,1,false,
            fast_subscrv(i, buffer)));
      i fi_+ 1 -> i;
   enduntil;
   move_subvector(1, buffer, 1, initv(i - 1) ->> buf1, i - 1);
   if n > i do
      move_subvector(i + 1, buffer, 1, initv(n - i) ->> buf2, n - i);
   endif;
   return({% explode(buf1), explode(refs), explode(buf2) %});
enddefine;


define refer(buffer) -> buffer;
   lvars buffer refs raw_refs bib_entries roff_output bib_entry i j k tag;
   process_citations(buffer, derive_num_citations) -> buffer -> raw_refs;
   {% applist(process_bib(raw_refs), identfn) %} -> bib_entries;
   current_target_spec == "roff" or current_target_spec == "tex" -> roff_output;
   {% get_bib_strings(bib_pre_bib_strings);
      bib_bibliography_title; vednullstring;
       for i from 1 to (datalength(bib_entries) ->> n) do
          fast_subscrv(i, bib_entries) -> bib_entry;
          ><_all(['[' ^i ']']) -> tag;
          if roff_output then bib_entry(1); 2 else 1 endif -> k;
          for j from k to datalength(bib_entry) do
             (if j == k then
                   tag >< tab
                else
                   if roff_output do vednullstring else '   ' endif
                endif) >< bib_entry(j)
          endfor;
       endfor;
      get_bib_strings(bib_post_bib_strings) %} -> refs;
   insert_refs(refs, buffer) -> buffer;
   delete_blanks(buffer);
   merge_num_citations(buffer);
   [^buffer] -> buffer;
enddefine;

define get_citations(buffer) -> citations;
   lvars buffer citations;
   invisible_ved_apply(ved_get_cit_data,true,buffer) -> -> -> citations;
enddefine;

/*
-- Input utilties ---------------------------------------------------
*/

define bibreadin(input) -> b;
   lvars input n b;
   if isinteger(vedreadin(input) ->> n) then
      consvector(n) -> b;
      invisible_ved_apply(
         procedure; until vedatend() do vednextline() enduntil endprocedure,b)
   else
      vederror('INTERRUPTED')
   endif;
   /* dup() <> bib_raw_input -> bib_raw_input; */
enddefine;


define trim_line(string) -> string;
   lvars string n = vedusedsize(string);
   if datalength(string) fi_> n then
      substring(1, n, string) -> string;
   endif;
enddefine;

define trim_lines;
   ncmapdata(trim_line)
enddefine;

define read_file(f) -> vec;
   lvars f tmpfile host, input n i vec = #_<{}>_#, line;
   if (locchar(`*,1,f) or locchar(`?,1,f)) then
      sysobey_output(false, 'cat '>< f)
   elseif (fileparse(f) ->> host) then
      -> f;
      sysobey_output(false, 'rsh '><host><' cat '>< f)
   else
      ->;
      f
   endif.bibreadin -> vec;
enddefine;


define read_disc_input(file);
   lvars file;
   if file = corebibname
   and isvector(core_input) then
      bibjob_message('Using existing corebib');
      core_input
   else
      if file = corebibname and not(readable(corebibname)) then
        bibjob_message('WARNING: '><corebibname><' is empty');
        syssleep(100);
      endif;
      read_file(file)
   endif
enddefine;


define read_ved_input(lo, hi, buffer) -> result;
   lvars n = (hi - lo) + 1, buffer, result;
   if n fi_< 1 then return(#_<{}>_#) endif;
   move_subvector(lo,buffer,1,initv(n) ->> result, n);
   trim_lines(result) -> result;
enddefine;


/*
-- Output utilities -------------------------------------------------
*/

define vedput_processed_bib(processed_bib);
   vars flashdata data;
   if isprocedure(flashdata)
   and length(maplist(processed_bib, explode) ->> data) fi_< 10 then
      flashdata(data)
   else
      processed_bib ==>
   endif;
enddefine;

define write_buffers(buffers, file, get_dev);
   lvars dev buffers line entry blanks i;
   if isdevice(get_dev) then
      get_dev -> dev;
   else
      unless get_dev(file, 1, "line") ->> dev do
         syscreate(file, 1, "line") -> dev
      endunless;
      sysseek(dev, 0, 2);
   endif;
   for entry in buffers do
      for i from 1 to vedusedsize(entry) do
         subscrv(i, entry) -> line;
         syswrite(dev,line,vedusedsize(line));
         syswrite(dev,'\n',1);
      endfor;
         /* syswrite(dev,'\n',1); */
   endfor;
   sysclose(dev);
enddefine;

define write_processed_bib;
   write_buffers(syscreate);
enddefine;

define vedinsert_processed_bib(processed_bib);
   vars i entry line, vedleftmargin, vedautowrite = false, vedbreak = false;
   if processed_bib /== [] do
      vedlinebelow();
      vedmarklo();
      for entry in processed_bib do
         for i from 1 to datalength(entry) do
            entry(i) -> line;
            vedinsertstring(line);
            veddocr();
         endfor;
      endfor;
      until (vedtrimline(), vedthisline() /= '') do vedcharup() enduntil;
      vedmarkhi();
   endif;
enddefine;


/* Checks if in a background job. If so does a busy (i.e. interruptable)
wait. */
define nice_syswait(child_pid);
   lvars child_pid, start = sys_real_time();
   if pop_current_process
   and pop_current_process == background_bibjob do
      repeat
         /* while sys_send_signal(child_pid, 17) do */
         suspend(0);
      quitif(bib_force_wait);
         if (sys_real_time() fi_- start) fi_> bib_roffjob_maxtime then
            vedputmessage('Forcing wait for roff-job: '><child_pid);
            quitloop
         endif;
      endrepeat;
   endif;
   until syswait() do enduntil;
enddefine;


define try_trim_rsh(com) -> com;
   lvars rsh_com = 'rsh '>< pophost("systemname"), n = datalength(rsh_com);
   if issubstring(rsh_com, 1, com) == 1 then
      substring(n + 2, datalength(com) - n - 1, com) -> com;
   endif;
enddefine;


/* The "up" pipe is the pipe carrying input up from the UNIX process
to the POPLOG process. The down pipe goes the other way. */

define sysobey_output(input_data, com) -> up_pipe_in;
   lvars com child_pid down_pipe_out down_pipe_in input_data up_pipe_in up_pipe_out;
   unless sys_os_type matches [unix ==] do
      mishap('Trying to spawn a UNIX process on a non-UNIX system', [])
   endunless;
   syspipe("line") -> up_pipe_in -> up_pipe_out;
   syspipe("line") -> down_pipe_in -> down_pipe_out;
   /* try_trim_rsh(com) -> com; */
   if sysfork() ->> child_pid then
      bibjob_message(com);
      if ispair(input_data) do write_buffers(input_data, false, down_pipe_out) endif;
      nice_syswait(child_pid);
      applist([% down_pipe_in, up_pipe_out %], sysclose);
   else
      identfn -> popexit;
      [] -> vedbufferlist;
      false -> vedediting;
      if sysobey_doublefork and sysfork() do
         sysopen('/dev/null',2,"line") ->> popdevin ->> popdevraw -> popdevout;
         sysexit();
      endif;
      applist([% up_pipe_in, down_pipe_out %], sysclose);
      /* unless bib_show_error_output do
         sysopen('/dev/null',1,"line") -> popdeverr;
      endunless; */
      down_pipe_in -> popdevin;
      up_pipe_out -> popdevout;
      sysexecute('/bin/csh', ['/bin/csh' '-c' ^com], false);
      sysexit();
   endif;
enddefine;

define sysdo(input, com);
   vars pr = identfn;
   com >< ' << FOOBAZ \n '>< hd(join_lines([% explode(input) %])) >< '\nFOOBAZ'
      -> com;
   [% csh_compile(stringin(com)) %]
enddefine;


define write_processed_bib_nroff_printer;
   sysobey_output(bib_nroff_com >< ' | ' >< bib_lp_com) ->;
enddefine;


define write_processed_bib_troff_printer(buffers);
   lvars com buffer; vars vedediting = false;
   if bib_ts_com = '' then
      bib_troff_com
   else
      bib_troff_com >< ' | '><bib_ts_com
   endif -> com;
   sysobey_output(buffer, com) ->;
enddefine;


define write_processed_bib_printer;
   sysobey_output(bib_lp_com) ->;
enddefine;


define write_processed_bib_vprinter(output, com);
   lvars output file buffer; vars sysobey_doublefork = false;
   sysobey_output(output, com) ->;
   if issubstring(bib_nroff_com, 1, com) and bib_nvp_translate_codes then
      bibjob_message('Translating codes');
      until readable('nroff_vprinter') do enduntil;
      bibreadin('nroff_vprinter') -> buffer;
      interpret_escape_codes(buffer) -> buffer;
      write_processed_bib([^buffer], 'nroff_vprinter');
   endif;
enddefine;


define write_processed_bib_nroff_vprinter;
   write_processed_bib_vprinter(bib_nroff_com >< ' > nroff_vprinter');
enddefine;

define write_processed_bib_troff_vprinter;
   write_processed_bib_vprinter(bib_troff_com >< ' -a > troff_vprinter');
enddefine;


/*
-- Command interpreter ----------------------------------------------
*/

define do_core_check;
   run_time_setup();
   unless isproperty(core_citations_map) do
      bibjob_message('Reading '><corebibname);
      false -> core_input;
      unless readable(corebibname) do
         sysclose(syscreate(corebibname,0,false));
      endunless;
      read_disc_input(corebibname) -> core_input;
      derive_citations_map(core_input) -> core_citations_map;
      set_core_authors();
   endunless;
enddefine;

define extract_control_spec(tag, default);
   vars item a z;
   if current_args matches [??a ^tag ?item ??z] then
      a <> z -> current_args;
      item
   else
      default
   endif
enddefine;


define parse_job_spec(spec) -> style_spec -> target_spec;
   vars item, ts = target_specs, ss = style_specs, style_spec = bib_style_spec, target_spec = bib_target_spec;
   if (locchar(`/,1,spec) ->> i) then ` ` -> spec(i) endif;
   for item in sysparse_string(spec) do
      consword(item) -> item;
      if member(item, ts) then
         item -> target_spec; [] -> ts;
      elseif member(item, ss) then
         item -> style_spec; [] -> ss;
      endif;
   endfor;
enddefine;


define set_current_program(spec);
   bibtoolprogs(spec) -> current_program;
   add_defaults(current_program, bibtoolprogs(false)) -> current_program;
enddefine;


define set_current_program_&_target(spec);
   lvars spec item;
   parse_job_spec(spec) -> current_style_spec -> current_target_spec;
   set_current_program(current_style_spec);
enddefine;


define backjob_mess;
   vedscreenbell();
   bibjob_message('DONE background job');
   vedwiggle(vedline,vedcolumn);
enddefine;


define try_suspend;
   if pop_current_process then suspend(0) endif
enddefine;


define timeout_compile;
   vars bibjob_message = erase;
   if vedediting and isliveprocess(background_bibjob) then
      syssettimer(100, try_suspend);
      runproc(0, background_bibjob);
      /*  vedputmessage('You have control'); */
   else
      identfn -> pop_timeout;
      false ->> pop_timeout_secs -> background_bibjob;
      chain(backjob_mess);
   endif;
enddefine;

define bibcorebibinit;
    run_time_setup();
    do_core_check();
enddefine;

define bibjob(temp_def_inp_spec, temp_def_outp_spec, temp_def_job_spec, pdr);
   vars x a z; lvars i, background = false;
   [] -> bib_bad_citations;
   run_time_setup();
   vedbufferextend();
   /* {} -> bib_raw_input; */
   unless no_core_check do do_core_check() endunless;
   if vedargument = '.' do '< .' -> vedargument endif;
   sysparse_string(vedargument) -> current_args;
   maplist(current_args, procedure(s); s sys_>< '' endprocedure) -> current_args;
   if current_args /== [] and (last(current_args) = '&' ->> background) do
      allbutlast(1, current_args) -> current_args
   endif;
   extract_control_spec('<', temp_def_inp_spec) -> current_input_spec;
   extract_control_spec('>', temp_def_outp_spec) -> current_output_spec;
   extract_control_spec('|', temp_def_job_spec) -> current_job_spec;

   /* Set program and target. */
   set_current_program_&_target(current_job_spec);

   /* Set current input. */
   if current_input_spec = direct_flag or current_input_spec = cit_flag do
      if current_args /== [] then
         {% hd(join_lines(current_args)) %}
      elseif current_input_spec = cit_flag
      and (issubstringall(bib_ref_centuries, vedcolumn, vedthisline()) ->> i)
      and vvedlinesize >= (i + 3)
      and isdate(substring(i,4,vedthisline())) do
         {% hd(join_lines(ved_get_citation(i) -> -> ->)) %}
      else
         {% vedcurrentitem() >< '' %}
      endif
   elseif current_input_spec = cit_flag then
   elseif current_input_spec = range_flag then
      read_ved_input(vvedmarklo, vvedmarkhi, vedbuffer)
   elseif current_input_spec = buffer_flag then
      read_ved_input(1, vedusedsize(vedbuffer), vedbuffer)
   else
      read_disc_input(current_input_spec)
   endif -> current_input;

   if (bib_output_pseudonyms(consword(current_output_spec)) ->> x) then
      x sys_>< '' -> current_output_spec;
   endif;

   /* Override current target spec if appropriate. */
   if member(current_output_spec, [^troff_spec ^nroff_spec
            ^ditroff_vprinter_spec ^nroff_vprinter_spec ^troff_vprinter_spec]) do
      "roff" -> current_target_spec;
   endif;

   /* Set current output. */
   if current_output_spec = direct_flag then
      vedput_processed_bib
   elseif current_output_spec = range_flag then
      vedinsert_processed_bib
   elseif current_output_spec = troff_spec then
      write_processed_bib_troff_printer
   elseif current_output_spec = nroff_spec then
      write_processed_bib_nroff_printer
   elseif current_output_spec = printer_spec then
      write_processed_bib_printer
   elseif current_output_spec = nroff_vprinter_spec then
      /* ???? consword(nroff_vprinter_spec) -> current_output_spec; */
      write_processed_bib_nroff_vprinter
   elseif current_output_spec = troff_vprinter_spec then
      /* consword(troff_vprinter_spec) -> current_output_spec; */
      write_processed_bib_troff_vprinter
   else
      write_processed_bib(%sysfileok(current_output_spec)%)
   endif -> current_output;

   /* Set message. */
   bibjob_message(><_all([
            %if background then 'DOING &: ' else 'DOING: ' endif%
            %sysfullfilename(current_input_spec), ' | ',
             current_job_spec, ' > ', sysfullfilename(current_output_spec) %]));

   /* Execute procedure. */
   if background then
      if isprocess(background_bibjob)
      and isliveprocess(background_bibjob) do
         mishap('You already have a backgound job going', [])
      else
         consproc(0, pdr) -> background_bibjob;
         timeout_compile -> pop_timeout;
         2 -> pop_timeout_secs;
      endif;
   else
      apply(pdr);
   endif;
   if pop_timeout /== timeout_compile
   and isstring(current_output_spec)
   and current_output_spec /= '.'
   and readable(current_output_spec) then
      if current_output_spec = ditroff_vprinter_spec then
         bibjob_message(ditroff_vprinter_spec >< ' written');
         return
      elseif (vedpresent(current_output_spec) ->> x) then
         vedselect(current_output_spec);
         ved_q();
      endif;
      syssleep(100); /* give some extra time for NFS to work */
      vedselect(current_output_spec);
   endif;
enddefine;

/* Non-interactive bibjob. */
define ni_bibjob(pdr, vedargument);
   vars bibjob_message = erase;
   pdr();
enddefine;


/*
-- ENTER commands ---------------------------------------------------
*/


define ved_nvp;
   vedselect(nroff_vprinter_spec);
enddefine;

define ved_bibcitations;
   vars current_citations_map not_core_citation = true, tags;
   bibjob(buffer_flag, bib_output_file, default_job_spec,
         procedure;
            derive_raw_ref_citations(parse_raw_bib(current_input),
                  "no_punctuation") -> tags;
            current_output(
                  [{% dl(maplist(tags, procedure(x); x(2) endprocedure)) %}]);
         endprocedure);
enddefine;

define ved_addall;
   vars current_citations_map not_core_citation = true, tags;
   bibjob(buffer_flag, direct_flag, default_job_spec,
         procedure;
            applist(parse_raw_bib(current_input),
                  bib_update_from_raw_ref(%corebibname%));
         endprocedure);
enddefine;


define ved_dst;
   parse_job_spec(vedargument) -> bib_style_spec -> bib_target_spec;
   bib_style_spec; bib_target_spec;
enddefine;


define ved_mdst;
   vars spec vedargument = vednullstring, update_screen = false;
   [% appproperty(bibtoolprogs, erase) %] -> style_specs;
   if (menuselect(style_specs) ->> spec) /== [] then
      consword(hd(spec)) -> bib_style_spec;
   endif;
   true -> update_screen;
   if (menuselect(target_specs) ->> spec) /== [] then
      consword(hd(spec)) -> bib_target_spec;
   endif;
   ved_dst();
enddefine;

define ved_sortbib;
   vars no_core_check = true, current_citations_map;
   bibjob(corebibname, bib_output_file,
         'sort',
         procedure;
            derive_citations_map(current_input) -> current_citations_map;
            current_output(sort_bib(get_current_bib()));
         endprocedure);
enddefine;

define citrefs(input_spec, output_spec);
   bibjob(input_spec, output_spec, default_job_spec,
      procedure;
         lvars input;
         current_input -> input;
         assign_core_to_current();
         full_refer(input,false) ->;
         current_output(process_bib(bib_refs_cited));
      endprocedure);
enddefine;

define ved_lookbib;
   bibjob(cit_flag, direct_flag, default_job_spec,
      procedure;
         lvars input;
         current_input -> input;
         assign_core_to_current();
         current_output(process_bib(lookbib(input)));
      endprocedure);
enddefine;
/* vedsetkey('\^[l', ved_lookbib); */

define ved_lookall; vars bib_lookall = true; ved_lookbib() enddefine;

define ved_lookbibcit;
   vars current_citations_map, tags;
   bibjob(direct_flag, direct_flag, default_job_spec,
         procedure;
            [% explode(current_input) %] -> current_input;
            derive_raw_ref_citations(lookbib(current_input), true) -> tags;
            current_output(
                  [{% dl(maplist(tags, procedure(x); x(2) endprocedure)) %}]);
         endprocedure);
enddefine;

define ved_lookallcit; vars bib_lookall = true; ved_lookbibcit() enddefine;

define vedrefer(refer_pdr);
   if issubstring('> mr',1,vedargument) then
      make_bib -> refer_pdr
   endif;
   bibjob(buffer_flag, bib_output_file, default_job_spec,
      procedure(refer_pdr);
         lvars input;
         current_input -> input;
         assign_core_to_current();
         current_output(refer_pdr(input));
      endprocedure(%refer_pdr%));
enddefine;

define ved_fullrefer; vedrefer(full_refer); enddefine;

define ved_refer;
   vars bib_sort_strategy = bib_refer_sort_strategy;
   vedrefer(refer);
enddefine;

define ved_citnames;
   bibjob(buffer_flag, bib_output_file, default_job_spec,
      procedure;
         lvars input;
         current_input -> input;
         assign_core_to_current();
         full_refer(input, false) ->;
         current_output([ {% dl(sort(nodups(
               maplist(bib_refs_cited,
               get_author_names_from pdcomp dl)))) %} ]);
      endprocedure);
enddefine;

define ved_cits;
   lvars cits;
   bibjob(buffer_flag, bib_output_file, default_job_spec,
      procedure;
         lvars input;
         current_input -> input;
         assign_core_to_current();
         full_refer(input, false) ->;
         nodups(maplist(bib_good_citations, join_lines <> hd)) -> cits;
         if bib_sort_strategy then sort(cits) -> cits endif;
         current_output([ {% dl(cits) %} ]);
      endprocedure);
enddefine;

define ved_citrefs; citrefs(buffer_flag, bib_output_file); enddefine;

define ved_getcitations; vedrefer(get_citations); enddefine;

define list_to_string(list);
   vars cucharout = identfn;
   cons_with consstring {% ppr(list) -> %}
enddefine;


/* Check Bad Citations . */
define ved_cbc;
   lvars bad_citation line;
   unless ispair(cbc_citations) do bib_bad_citations -> cbc_citations endunless;
   if cbc_citations /== [] do
      fast_destpair(cbc_citations) -> cbc_citations -> bad_citation;
      bad_citation(1) -> line;
      line -> vedline;
      syssleep(100);
      vedputcommand('lookbib '><list_to_string(tl(bad_citation)));
   else
      'No more' -> vedmessage;
   endif;
enddefine;


define ved_processbib;
   vars no_core_check = true, current_citations_map;
   bibjob(buffer_flag, bib_output_file, default_job_spec,
      procedure;
         derive_citations_map(current_input) -> current_citations_map;
         current_output(process_bib(get_current_bib()))
      endprocedure);
enddefine;

vars ved_roffbib = ved_processbib;

/* read New Core Bib. */
define ved_ncb; false -> core_citations_map; do_core_check() enddefine;
define ved_vcb; run_time_setup(); vedselect(corebibname) enddefine;


/* Copy the input to the output. */
define ved_cat;
   vars no_core_check = true;
   bibjob(buffer_flag, bib_output_file, default_job_spec,
      procedure;
         current_output([^current_input]);
      endprocedure);
enddefine;


/* Connect up the IO streams to a csh process */
define ved_csh;
   vars no_core_check = true;
   bibjob(direct_flag, direct_flag, default_job_spec,
      procedure;
         lvars n new_vec vec i;
         current_output([%
         bibreadin(sysobey_output([],
               hd(join_lines(current_args)))) %]);
      endprocedure);
enddefine;


/*
-- Printer/virtual-printer commands ---------------------------------
*/

define ved_pr;
   veddo('cat > printer '><vedargument)
enddefine;

/* Where are the roff printers? */
define ved_nroff_printer;
   vedputmessage(''sys_><bib_lp_com)
enddefine;

define ved_troff_printer;
   vedputmessage(bib_ts_coms sys_><'')
enddefine;

define ved_npq;
   lvars i com;
   /* A beautiful Kludge -- won't work for sys. 5 */
   if (issubstring('lpr',1,bib_lp_com) ->> i)
   or (issubstring('tpr',1,bib_lp_com) ->> i) then
      `q -> subscrs(i + 2, copy(bib_lp_com) ->> com);
      'Printer queue (' >< com >< ')' =>
      sysobey(com);
   endif;
enddefine;

define ved_tpq;
   vars poplinewidth = 200, poplinemax = poplinewidth;
   /* npr('Troff printer queue: (rsh cgeca lpstat)');
   sysobey('rsh cgeca lpstat -u'); */
   'Troff printer queue: (lpq -Plw)' ==>
   sysobey('lpq -Plw');
enddefine;

define ved_nprm;
   lvars i com;
   /* A beautiful Kludge -- won't work for sys. 5 */
   if (issubstring('lpr',1,bib_lp_com) ->> i)
   or (issubstring('tpr',1,bib_lp_com) ->> i) then
      substring(1, datalength(bib_lp_com) - 1, bib_lp_com)
            >< 'rm ' >< popusername -> com;
      'Trying: ' >< com =>
      sysobey(com);
   endif;
enddefine;

define ved_pq; ved_npq() enddefine;

define ved_bibms;
   vars menu_stepval_range, vedms_vars;
   run_time_setup();
   if vedargument = 'vs' then
      menu_stepval("bib_vert_spaces") -> bib_vert_spaces
   else
      newassoc([
         [bib_nroff_com ^bib_nroff_coms]
         [bib_troff_com ^bib_troff_coms]
         [bib_lp_com ^bib_lp_coms]
         [bib_ts_com ^bib_ts_coms]
         [bib_roffjob_maxtime {30 60 120 240}]
         [bib_style_spec {% appproperty(bibtoolprogs, erase) %}]
         [bib_target_spec {% dl(target_specs) %}]
         [bib_sort_strategy {author_date date reverse_date ^false}]
         [bib_refer_sort_strategy {author_date date reverse_date ^false}]
         ]) -> menu_stepval_range;
      #_<[
         bib_style_spec
         bib_target_spec
         bib_lp_com
         bib_ts_com
         bib_nroff_com
         bib_troff_com
         bib_nvp_translate_codes
         bib_full_justify
         bib_initials_only
         bib_et_al_abbreviate
         bib_ibid_abbreviate
         bib_ibid_limit
         bib_ignore_case
         bib_sort_strategy
         bib_refer_sort_strategy
         bib_roffjob_maxtime
         bib_force_wait
         ]>_# -> vedms_vars;
      ved_ms();
   endif
enddefine;

define ved_mbsl;
    run_time_setup();
    procedure; menuselect() -> bibsearchlist; endprocedure(%bibsearchlist%)
            ->> ved_mbsl;
    apply();
enddefine;

/* Procedure to convert structured-format refs into raw refs */
define convert_ref;
   lvars c;
   if skipchar(` `,1,vedthisline()) == 1 then
      {%
      '%A '><vedthisline(), vednextline(); vedwordright();
      vedcolumn -> c;
      '%B ' ><substring(c, vvedlinesize - c + 1, vedthisline()),
      vednextline(), vedtextright(),
      '%D '><vedmovebackitem(), vedwordleft(),
      vedcolumn -> c; vedscreenleft(), vedwordright(),
      '%I '><substring(vedcolumn, c - vedcolumn, vedthisline()),
      '\t'
      %}
   else
      false
   endif
enddefine;


define convert_all(b);
   invisible_ved_apply(
      procedure;
         lvars rf input;
         vedtopfile();
         [% until vedatend() do
                if convert_ref() ->> rf then rf; endif;
                vednextline();
             enduntil; %]
      endprocedure,b)
enddefine;

define ved_convert_refs;
   bibjob(buffer_flag, bib_output_file, default_job_spec,
         procedure; current_output(convert_all(current_input)); endprocedure);
enddefine;

define ved_ccbn;
   if vedargument = vednullstring then
      corebibname
   else
      vedargument -> corebibname;
      [^corebibname] -> bibsearchlist;
      false -> core_citations_map;
   endif;
enddefine;

vars bibtool = identfn;

/* --- Revision History ---------------------------------------------------
--- Aaron Sloman, Feb  4 2001
		Made splice lconstant to prevent clashes with other packages
--- John Williams, Apr 18 1989
        Changed lvar 'ref' to 'rf' to avoid macro expansion problems
 */
