Gamma and other image manipulation commands

[TeXnicard.git] / texnicard.w

% TeXnicard
% version 0.1

% Licensed by GNU GPL v3 or later version.

\def\contentspagenumber{1}\pageno=3
\def\title{\TeX nicard}
\def\covernote{{\fiverm Batteries not included. Do not use this book as a
flotation device. This is free software; see source file for details.}}

% Prevent \outer from getting in the way, stupid!
\def\+{\tabalign}

@mp@-
``u{YJ"@<Predeclaration of procedures@>=
qJA";
J"@
"@<Procedure codes@>=
B" {
@)

\long\def\IndexCharacter#1':{`\.{\char`#1}'}
@mcase@-
``u "case
qAqA/@!@^\IndexCharacter\
Bqu'B"@>
YJ"@<Nothing~@>
@)

\iffalse
@s _decl_head_ =09
@s FILE int
@s dvi_measure int
\fi

\newcount\bibliocount \bibliocount=0
\def\biblio#1{%
  \advance\bibliocount by 1 %
  $^{[\the\bibliocount]}$%
  \expandafter\def\csname biblio \the\bibliocount\endcsname{#1}%
}%

\emergencystretch=\hsize

\def\strike#1{%
  \setbox0=\hbox{#1}%
  \rlap{\vrule height 3.2pt depth -2.5pt width \wd0}{\box0}%
}%

\def\sectionnumber\PB#1{\sectionnumbernext#1}
\def\sectionnumbernext$\X#1:#2\X${#1}

@*Introduction. This is \TeX nicard, a program designed for similar
purposes of Magic Set Editor, but in a different (and better) way. It
should be able to produce higher quality cards than Wizards of the Coast,
and then they ought to use this program, too!

@^Magic Set Editor@>
@^Wizards of the Coast@>
@^commercial viability@>

@c
@<Memory usage logging@>@;
@<Interpreted C codes@>@;
@<Include files@>@;
@h
@<Typedefs@>@;
@<Late Typedefs@>@;
@<The include file for memory managed types@>@;
@<Global variables@>@;
@<Predeclaration of procedures@>@;
@<Procedure codes@>@;

@ This line below should be changed with the current version number,
whenever a new version is released. (If you fork this program, you should
also include some indication of forking in the \\{version\_string}.)
% (it doesn't work if I use vertical bars here)

@^forking@>

@d version_string "0.1"
@d version_number 1 // one major is worth ten minors

@ @<Typedefs@>=
typedef unsigned char boolean;

@ You might be wondering what this section is for (especially since it
appears to be unused). The reason is that some metamacros use it in order
to force the compiler to know the correct line numbers (in case some lines
have been added by metamacros).

@^nothing@>
@^metamacro@>

@<Nothing~@>= /* ... */

@ There is also memory usage logging. If it is not being compiled for
memory usage logging, it should just ignore these kind of commands.

@<Memory usage logging@>=
#ifndef @!memusage_log
#define @[memusage_log(_text,_arg1)@]
#endif

@*Memory Management. This program uses a lot of similar memory management,
so they will be defined in this chapter.

@^memory management@>

@d none -1 // indication that a |data_index| means nothing

@<Typedefs@>=
typedef struct {
  char*data; // pointer to array of blocks (|char*| for use with |sizeof|)
  int used; // number of blocks used
  int allocated; // number of blocks allocated
} managed_memory;
@#typedef int data_index;

@ We will use an interpreted C code here, which will send output to a
header file |"memory_management.h"|.

@<The include file for memory managed types@>=
#include "memory_management.h"

@ We will need some variables now just to keep track of which kinds of
memory managed areas are needed.

@<Interpreted C codes@>= @{
  char**memory_managed_types;
  int num_memory_managed_types;
  memory_managed_types=malloc(128*sizeof(char*));
  num_memory_managed_types=0;
@}

@ From this code, the structure will be created in the header file for
each type that we need a |memory_of|. This section, however, is just a
``wrapper'' code for the template.

@f @!memory_of _decl_head_ // category 9

@<Interpreted C codes@>= @{
  void memory_of$() {
    should_output=0;
    set_goal("bp","",@+{
      sendc(0200|'{'); // begin interpret mode
      send("send_memory_of(\"");
      set_goal("e","",@+{
        send("\");");
        sendc(0200|'}'); // end interpret mode
        should_output=0;
      }@+);
    }@+);
  }
@}

@ Here is what it does in order to keep a list of the memory managed
types. Note the type name was enclosed in quotation marks, so now it will
be received as a string.

@<Interpreted C codes@>= @{
  void send_memory_of(char*s) {
    int i;
    s++;
    @<Send the proper name of the memory managed type@>;
    for(i=0;i<num_memory_managed_types;i++) {
      if(!strcmp(s,memory_managed_types[i])) return;
    }
    memory_managed_types[num_memory_managed_types++]=s;
  }
@}

@ @<Send the proper name of the memory managed type@>= {
  send(" x__");
  send(s);
  send(" ");
}

@ Now the code you get to in order to define the structures in the header
file. We are mostly just copying the form of our |managed_memory|
structure, but it will be customized to work with the specific type of the
|data| components.

@<Interpreted C codes@>= @{
  void send_memory_managed_types() {
    int i;
    for(i=0;i<num_memory_managed_types;i++) {
      send("typedef struct {");
      send(memory_managed_types[i]);
      send("*data; int used; int allocated; } x__");
      send(memory_managed_types[i]);
      send(";");
    }
  }
@}

@ @(memory_management.h@>= @{
  send_memory_managed_types();
@}

@ These next two subroutines are used to allocate additional memory.

@d init_memory(_a,_size) init_memory_(&(_a),sizeof(*((_a).data)),(_size))
@d new_record(_area) new_record_(&(_area),sizeof(*((_area).data)))

@-p void*init_memory_(void*mem,int record_size,int num_records) {
  managed_memory*m=mem;
  m->data=malloc(record_size*num_records);
  m->used=0;
  m->allocated=num_records;
  if(!m->data) @<Fatal error due to lack of memory@>;
  return m->data;
}

@ @-p data_index new_record_(void*mem,int record_size) {
  managed_memory*m=mem;
  m->used++;
  if(m->used>m->allocated) {
    m->allocated*=2;
    m->data=realloc(m->data,m->allocated*record_size);
  }
  if(!m->data) @<Fatal error due to lack of memory@>;
  @<Zero the new record@>;
  return m->used-1;
}

@ @<Fatal error due to lack of memory@>= {
  fprintf(stderr,"Out of memory\n");
@.Out of memory@>
  exit(1);
}

@ @<Zero the new record@>= {
  memset(m->data+(record_size*(m->used-1)),0,record_size);
}

@ Now just one more thing. It is useful to have a |foreach| macro to
iterate the areas.

@d foreach(_var,_area) for(_var=0;_var<_area.used;_var++)@;
@f foreach while

@*Symbolic Names. There will be some names defined for the use of naming
subroutines, symbolic constants, patterns, card areas, etc. These names
are stored in a |managed_memory| called |names|.

It also stores references to other things (defined in later chapters). The
numeric value of a name in |names.data[x]| is |x+256|.

@<Late Typedefs@>=
typedef struct {
  char*name;
  @<More elements of |name_data|@>@;
} name_data;

@ @<Global variables@>=
memory_of(name_data) names;

@ @<Initialize memory@>= init_memory(names,16);

@ This subroutine finds a name, adding it if necessary. The number
corresponding to it (as described above) will be the return value.

@-p int find_name(char*name) {
  @<Search for the |name| in |names|@>;
  @<Add the new name (it was not found)@>;
}

@ @<Search for the |name| in |names|@>= {
  int i;
  foreach(i,names) {
    if(!strcmp(names.data[i].name,name)) return i+256;
  }
}

@ @<Add the new name (it was not found)@>= {
  int n=new_record(names);
  names.data[n].name=strdup(name);
  return n+256;
}

@ A macro will be useful to access the data from a number.

@d name_info(_num) names.data[(_num)-0x0100]

@ This code lists the names. It is used for a diagnostic purpose.

@<Display the list of names@>= {
  int n;
  foreach(n,names) {
    printf("%d \"%s\" ",n+256,names.data[n].name);
    @<Display other fields of |names.data[n]|@>;
    printf("\n");
  }
}

@*Storage of Tokens. Tokens are stored as 16-bit numbers. Values |0x0020|
to |0x00FF| represent those ASCII characters, and |0x0000| to |0x001F| are
ASCII control codes. Higher numbers represent an index into the |names|
array (where |0x0101| represents |names.data[0x0001]|).

@<Typedefs@>=
@q[data type of tokens]@>
typedef unsigned short token;

@ This section lists the ASCII control codes which can be used. Some of
them have slightly different meaning from the ASCII standard.

@d null_char 0x00 // end of a |raw_data| string or similar things
@d pre_null_char 0x01 // becomes |null_char|
@d end_transmission 0x04 // marks the end of the last card in this area
@d tabulation 0x09 // represents a tab in a {\TeX} alignment
@d raw_data 0x10 // enter raw {\TeX} mode
@d whatsit 0x1A // a token for converting into a name token
@d escape_code 0x1B // represents a {\TeX} control sequence introducer
@d record_separator 0x1E // marks the end of a card
@d field_separator 0x1F // marks the end of a field of a card
@d start_name_code 0x0100

@ These tokens are used in card areas, which are defined (and described)
in the next chapter.

@*Cards. The data of the cards is stored in card areas. Each card area
is a list of tokens, terminated by |record_separator|. The final card in
the area is terminated by |end_transmission|.

@<Typedefs@>=
typedef struct {
  token*tokens;
  int allocated;
  int used;
} card_area_data;

@ @<More elements of |name_data|@>=
  boolean has_card_area;
  data_index card_area;

@ @<Global variables@>=
memory_of(card_area_data) card_areas;

@ @<Initialize memory@>= init_memory(card_areas,1);

@ A new card area is created with this.

@-p data_index set_card_area(int num) {
  name_data*m=&name_info(num);
  @<Use the card area which is already set, if able@>;
  @<Otherwise, create a new card area and use the new one@>;
}

@ @<Use the card area which is already set, if able@>= {
  if(m->has_card_area) return m->card_area;
}

@ @<Otherwise, create a new card area and use the new one@>= {
  data_index n=new_record(card_areas);
  m->has_card_area=1;
  card_areas.data[n].allocated=0x100;
  card_areas.data[n].tokens=malloc(0x100*sizeof(token));
  card_areas.data[n].used=0;
  return n;
}

@ This subroutine sends a token to a card area.

@-p void send_token(data_index a,token x) {
  if(card_areas.data[a].allocated<card_areas.data[a].used+4)
    @<Double the allocation of card area tokens@>;
  card_areas.data[a].tokens[card_areas.data[a].used++]=x;
}

@ @<Double the allocation of card area tokens@>= {
  int n=(card_areas.data[a].allocated*=2)*sizeof(token);
  card_areas.data[a].tokens=realloc(card_areas.data[a].tokens,n);
}

@ @<Display other fields of |names.data[n]|@>= {
  if(names.data[n].has_card_area)
    printf("C(%d) ",names.data[n].card_area);
}

@ The code in this section is used to ensure that each card area is
properly terminated with |end_transmission| marker, so that when it is
time to write the output files, it will know when to stop.

@<Send |end_transmission| to each card area@>= {
  data_index a;
  foreach(a,card_areas) send_token(a,end_transmission);
}

@*Patterns. For pattern matching, we store the patterns in one memory
managed area. The index of the beginning of each pattern area is stored
in the |names| list.

These constants are special codes which can occur in the |text| string
of a pattern.

@d begin_capture 1
@d end_capture 2
@d match_keyword 3 // match a keyword followed by a character in a table
@d match_table 4 // match a character using a table
@d optional_table 5 // match a character optional using a table
@d failed_match 6
@d jump_table 7 // use a table to jump to a marker
@d successful_match 8
@d back_one_space 9
@d forward_one_space 10
@d match_left_side 11 // match at beginning of line
@d match_right_side 12 // match at end of line
@d match_eight_bit 13 // match 8-bit encodings and control characters

@<Typedefs@>=
typedef struct {
  char*text;
  unsigned int category; // category for keywords
  data_index subroutine;
  data_index next;
} pattern_data;

@ @<More elements of |name_data|@>=
  boolean has_pattern_area;
  data_index pattern_area;

@ @<Global variables@>=
memory_of(pattern_data) pattern_areas;

@ @<Initialize memory@>= init_memory(pattern_areas,4);

@ @<Display other fields of |names.data[n]|@>= {
  if(names.data[n].has_pattern_area)
    printf("P(%d) ",names.data[n].pattern_area);
}

@ A new pattern area is created with this. The patterns in an area are
stored like a linked list. The last one with |next| pointing to nothing,
is the terminator entry.

@-p data_index set_pattern_area(int num) {
  name_data*m=&name_info(num);
  @<Use the pattern area which is already set, if able@>;
  @<Otherwise, create a new pattern area and use the new one@>;
}

@ @<Use the pattern area which is already set, if able@>= {
  if(m->has_pattern_area) return m->pattern_area;
}

@ @<Otherwise, create a new pattern area and use the new one@>= {
  data_index n=new_record(pattern_areas);
  m->has_pattern_area=1;
  pattern_areas.data[n].subroutine=none;
  pattern_areas.data[n].next=none;
  return n;
}

@ @<Display the list of patterns@>= {
  int i;
  foreach(i,pattern_areas) {
    if(pattern_areas.data[i].text) {
      printf("%d:%08X:%d:%d\n",i,pattern_areas.data[i].category
        ,pattern_areas.data[i].subroutine,pattern_areas.data[i].next
      );
      display_string(pattern_areas.data[i].text);
      printf("\n");
    }
  }
}

@*Keywords. Keywords means words which can be placed on the card and which
can have special meanings, and possibly reminder text.

Keywords are stored in a large list in only one keyword area. A category
can be given a name, which will automatically be assigned for the next bit
of the keyword category when it is entered the first time.

@<Typedefs@>=
typedef struct {
  char*match; // match text (can contain pattern codes)
  unsigned int category; // bitfield of categories
  int extra1;
  int extra2;
  char*replacement; // replacement text or reminder text
} keyword_data;

@ @<Global variables@>=
unsigned int next_keyword_category=1;
memory_of(keyword_data) keywords;

@ @<Initialize memory@>= init_memory(keywords,4);

@ A keyword category is found (and created, if it is not found) using the
following code.

@-p unsigned int find_category(char*name) {
  int i=find_name(name);
  if(name_info(i).value.number) {
    return name_info(i).value.number;
  } @+else if(!name_info(i).value.is_string) {
    name_info(i).value.number=next_keyword_category;
    next_keyword_category<<=1;
    if(!next_keyword_category)
      fprintf(stderr,"Too many keyword categories: %s\n",name);
@.Too many keyword categories@>
    return name_info(i).value.number;
  }
}

@ Some stack code commands are used when dealing with reading/writing
keyword info.

In order that you might be able to iterate them, it will exit out of the
current block when trying to read nonexisting keyword info instead of
displaying an error message.

@<Cases for system commands@>=
  @-case 'k': {
    // Read keyword info
    if(registers['K'].number<0 || registers['K'].number>=keywords.used)
      return 0;
    push_num(keywords.data[registers['K'].number].extra1);
    push_num(keywords.data[registers['K'].number].extra2);
    push_string(keywords.data[registers['K'].number].replacement);
    break;
  }@#
  @-case 'K': {
    // Write keyword info
    if(registers['K'].number<0 || registers['K'].number>=keywords.used)
      program_error("Out of range");
    free(keywords.data[registers['K'].number].replacement);
    keywords.data[registers['K'].number].replacement=pop_string();
    keywords.data[registers['K'].number].extra2=pop_num();
    keywords.data[registers['K'].number].extra1=pop_num();
    break;
  }@#

@ @<Display the list of keywords@>= {
  int i;
  foreach(i,keywords) {
    display_string(keywords.data[i].match);
    printf("  [%d:%08X:%d:%d:%d]\n",i,keywords.data[i].category
      ,keywords.data[i].extra1,keywords.data[i].extra2
      ,strlen(keywords.data[i].replacement)
    );
  }
}

@*Card List. A sorted summary list of the cards is kept in one list,
having thirty-two general-purpose numeric fields, and a pointer to the
beginning of the record (usually the name in which it will be indexed by).

@<Typedefs@>=
typedef struct {
  int token_ptr;
  int field[32];
  int amount_in_pack; // used in pack generation
} list_entry;

@ @<Global variables@>=
memory_of(list_entry) card_list;

@ @<Initialize memory@>= init_memory(card_list,16);

@*Deck Lists. Deck lists involve lists of cards or rules for cards that
belong to a deck or pack.

@^booster pack@>

There is one macro |lflag| here just to convert letters to bit flags. For
example |lflag('a')| is the least significant bit.

@d lflag(_ch) (1<<((_ch)-'a'))

@<Typedefs@>=
typedef struct {
  int amount;
  unsigned int flags;
  char*name;
  data_index next;
} deck_entry;

@ @<Global variables@>=
memory_of(deck_entry) deck_lists;

@ @<More elements of |name_data|@>=
  boolean has_deck_list;
  data_index deck_list;

@ @<Initialize memory@>= init_memory(deck_lists,4);

@ A new deck list is created with this. The deck entries are stored like a
linked list. The terminator has |next| pointing to |none|.

@-p data_index set_deck_list(int num) {
  name_data*m=&name_info(num);
  @<Use the deck list which is already set, if able@>;
  @<Otherwise, create a new deck list and use the new one@>;
}

@ @<Use the deck list which is already set, if able@>= {
  if(m->has_deck_list) return m->deck_list;
}

@ @<Otherwise, create a new deck list and use the new one@>= {
  data_index n=new_record(deck_lists);
  m->has_deck_list=1;
  deck_lists.data[n].next=none;
  return n;
}

@ @<Display the deck list@>= {
  data_index i;
  foreach(i,deck_lists) {
    printf("%d ",i);
    if(deck_lists.data[i].name) display_string(deck_lists.data[i].name);
    else printf("-");
    printf(" [%08X:%d:%d]\n",deck_lists.data[i].flags
      ,deck_lists.data[i].amount,deck_lists.data[i].next);
  }
}

@*Image Manipulators. Image manipulators are used to render the card
images from the typesetting and external PNG files and special effects.
Each line of code is one or more 16-bit unsigned numbers, where the first
number indicates what command is being used. These specify effects such as
convolution, blur, mask, etc.

@<Typedefs@>=
typedef struct {
  unsigned char data_len;
  unsigned short*data;
  data_index next;
} image_manipulator;

@ @<Global variables@>=
memory_of(image_manipulator) image_manips;

@ @<More elements of |name_data|@>=
  boolean has_image_manip;
  data_index image_manip;

@ @<Initialize memory@>= init_memory(image_manips,1);

@ Creating a new image manipulation is similar to a new deck list and so
on. The program is a linked list of the program lines, with the terminator
|next| pointing to |none|.

@-p data_index set_image_manip(int num) {
  name_data*m=&name_info(num);
  @<Use the image manipulator which is already set, if able@>;
  @<Otherwise, create a new image manipulator and use the new one@>;
}

@ @<Use the image manipulator which is already set, if able@>= {
  if(m->has_image_manip) return m->deck_list;
}

@ @<Otherwise, create a new image manipulator and use the new one@>= {
  data_index n=new_record(image_manips);
  m->has_image_manip=1;
  image_manips.data[n].next=none;
  return n;
}

@*Word Forms. These structures are used to store word form rules, such as
plurals\biblio{Conway, Damian. ``An Algorithmic Approach to English
Pluralization''. \hskip 0pt plus 1in\hbox{}
\.{http://www.csse.monash.edu.au/\~damian/papers/HTML/Plurals.html}}. You
can store up to four different kinds, in case of languages other than
English.

@^Conway, Damian@>
@^plurals@>

@<Typedefs@>=
typedef struct {
  int level;
  data_index next;
  unsigned char orig[32];
  unsigned char dest[32];
  boolean left_boundary;
  boolean right_boundary;
} word_form_entry;

@ @<Global variables@>=
memory_of(word_form_entry) word_forms;

@ @<Initialize memory@>= {
  int i;
  init_memory(word_forms,16);
  word_forms.used=8;
  for(i=0;i<8;i+=2) {
    word_forms.data[i].orig[0]=word_forms.data[i].dest[0]=0;
    word_forms.data[i].next=i+1;
    word_forms.data[i].level=0x7FFFFFFF;
    word_forms.data[i+1].orig[0]=word_forms.data[i+1].dest[0]=0;
    word_forms.data[i+1].next=none;
    word_forms.data[i+1].level=0;
  }
}

@ Word form rules are added and then inserted in the correct place in the
linked list using the |next| field. Entries with a higher numbered level
take higher priority, therefore will be placed before the ones with lower
numbered level. Next, longer |orig| strings come before shorter strings,
since they might be more specific forms of the others and will therefore
override them.

@-p data_index add_word_form(int kind,int level,char*orig,char*dest) {
  data_index n=new_record(word_forms);
  @<Set the fields of the new word form rule@>;
  @<Insert the new word form rule into the linked list@>;
  return n;
}

@ The |left_boundary| and |right_boundary| fields specify if they should
match only at the boundary. Characters are checked using the \.W table and
removed from the string to place in the list.

@d last_character(_str) ((_str)[strlen(_str)-1])

@<Set the fields of the new word form rule@>= {
  word_forms.data[n].level=level;
  strcpy(word_forms.data[n].orig,orig+(tables['W'][*orig]==2));
  word_forms.data[n].left_boundary=(tables['W'][*orig]==2);
  if((word_forms.data[n].right_boundary=
   (tables['W'][last_character(word_forms.data[n].orig)]==3)))
    last_character(word_forms.data[n].orig)=0;
  strcpy(word_forms.data[n].dest,dest+(tables['W'][*dest]==2));
  if(tables['W'][last_character(word_forms.data[n].dest)]==3)
    last_character(word_forms.data[n].dest)=0;
}

@ @<Insert the new word form rule into the linked list@>= {
  data_index y=(kind&3)<<1; // previous item to |x|
  data_index x=word_forms.data[y].next; // current item
  int s=strlen(orig);
  for(;x!=none;y=x,x=word_forms.data[y].next) {
    if(word_forms.data[x].next==none) break;
    @#if(word_forms.data[x].level<level) break;
    if(word_forms.data[x].level>level) continue;
    @#if(strlen(word_forms.data[x].orig)<s) break;
  }
  word_forms.data[y].next=n;
  word_forms.data[n].next=x;
}

@ Now to do computation of changing a word by word forms. This function
expects only one word from input, or multiple words where the last one
should be the word to be converted. Uppercase letters are converted to
lowercase for conversion (but not the other way around), but if the
letters are uppercase in the input, the output will also have uppercase
letters on those positions. The algorithm starts from the right side of
the input string.

The parameter |src| is the input, and |dest| should point to a buffer
which is large enough to store the output string.

@^plurals@>

@-p data_index reform_word(int kind,char*src,char*dest) {
  char*l=src+strlen(src);
  data_index n=word_forms.data[(kind&3)<<1].next;
  strcpy(dest,src); // this is used later
  @<Try each word form rule, following the |next| pointers@>;
  return none; // in case there is nothing to do
}

@ @<Try each word form rule, following the |next| pointers@>= {
  char*p;
  int s;
  while(n!=none && word_forms.data[n].next!=none) {
    s=strlen(word_forms.data[n].orig); @+ p=l-s;
    @<Check the characters matching from |p|, going backwards@>;
    n=word_forms.data[n].next;
  }
}

@ Look ahead for the definition of |wcasecmp| (true means it matches).

@<Check the characters matching from |p|, going backwards@>= {
  for(;;) {
    if((!word_forms.data[n].left_boundary || p==src
     || tables['W'][p[-1]])
      && wcasecmp(word_forms.data[n].orig,p))
       @<A match to the word form rules has been found@>;
    @<Go backwards, stop if we are not allowed to continue backwards@>;
  }
}

@ @<A match to the word form rules has been found@>= {
  char*o=dest+(p-src);
  sprintf(o,"%s%s",word_forms.data[n].dest,p+s);
  @<Change the capitalization to match the original@>;
  return n;
}

@ Remember, that for example if ``cow'' becomes ``kine'', then ``Cow''
will become ``Kine''. So, it will retain capitalization.

@^cows@>

@<Change the capitalization to match the original@>= {
  char*q=word_forms.data[n].orig;
  for(;*p && *q;p++,o++,q++)
    if(*p==tables['U'][*q] && *p!=tables['L'][*q]) *o=tables['U'][*o];
}

@ @<Go backwards, stop if we are not allowed to continue backwards@>= {
  if(word_forms.data[n].right_boundary) break; // matches only on boundary
  if(tables['W'][p[s]]) break; // only the last word(s) can be matched
  if(p--==src) break; // stop at beginning
}

@ This function is defined to compare strings in the way needed for
matching word forms, including case conversion. The lowercase letters in
the |shorter| string are permitted to match lowercase and uppercase
letters in the |longer| string, and the |shorter| string is permitted to
be shorter and still match.

@-p boolean wcasecmp(char*shorter,char*longer) {
  for(;;shorter++,longer++) {
    if(!*shorter) return 1;
    if(!*longer) return 0;
    if(*shorter!=*longer && *shorter!=tables['L'][*longer]) return 0;
  }
}

@ Of course it is now needed a command that can access these features from
within a \TeX nicard template. The |level| of the matched rule is also
returned, in case your program might use that information for something.

@<Cases for system commands@>=
  @-case 'W': {
    // Convert a word form
    int k=pop_num();
    char*o=pop_string();
    char q[1500];
    data_index n=reform_word(k,o,q);
    push_string(q);
    if(n==none) push_num(0);
    else push_num(word_forms.data[n].level);
    free(o);
    break;
  }@#

@ @<Display the list of word form rules@>= {
  data_index i;
  foreach(i,word_forms) {
    printf("%d %c\"",i,word_forms.data[i].left_boundary?'[':' ');
    display_string(word_forms.data[i].orig);
    printf("\"%c -> \"",word_forms.data[i].right_boundary?']':' ');
    display_string(word_forms.data[i].dest);
    printf("\" %d >%d\n",word_forms.data[i].level
      ,word_forms.data[i].next);
  }
}

@*Random Number Generation. This program uses the Xorshift algorithm,
invented by George Marsaglia\biblio{Marsaglia (July 2003). ``Xorshift
RNGs''. Journal of Statistical Software Vol.~8 (Issue 14). {\tt
http://www.jstatsoft.org/v08/i14/paper}.}.

@^Marsaglia, George@>
@^random numbers@>

@<Global variables@>=
unsigned int rng_x;
unsigned int rng_y;
unsigned int rng_z;
unsigned int rng_w;

@ @<Initialize the random number generator@>= {
@q[initialize the random seed::]@>
  rng_seed((unsigned int)time(0));
@q[::initialize the random seed]@>
}

@ The seed parameters for the random number generator will be seeded using
the linear congruential generator, which is a simpler generator which can
be used to seed it with.

The parameters |lcg_a| and |lcg_c| are parameters to the linear
congruential generator algorithm. The values used here are the same as
those used in GNU C. In this program they will be specified explicitly so
that you can get identical output on different computers.

@d lcg_a 1103515245
@d lcg_c 12345

@-p void rng_seed(unsigned int x) {
  rng_x=x=lcg_a*x+lcg_c;
  rng_y=x=lcg_a*x+lcg_c;
  rng_z=x=lcg_a*x+lcg_c;
  rng_w=x=lcg_a*x+lcg_c;
}

@ There is a command to reseed it using a constant (so that you can
generate the same numbers on different computers).

@<Cases for system commands@>=
  @-case 'U': {
    // Reseed the random number generator
    if(stack_ptr->is_string) program_error("Type mismatch");
    rng_seed(pop_num());
    break;
  }@#

@ And now follows the algorithm for generating random numbers. One change
has been made so that once it is modulo, all number will still be of equal
probability.

Numbers are generated in the range from 0 up to but not including |limit|.

@d max_uint ((unsigned int)(-1))

@-p unsigned int gen_random(unsigned int limit) {
  unsigned int r=max_uint-(max_uint%limit); // range check
  for(;;) {
    @<Make the next number |rng_w|...@>;
    @<Check the range, try again if out of range, else |return|@>;
  }
}

@ @<Make the next number |rng_w| by Xorshift algorithm@>= {
  unsigned int t = rng_x ^ (rng_x << 11);
  rng_x = rng_y; @+ rng_y = rng_z; @+ rng_z = rng_w;
  rng_w ^= (rng_w >> 19) ^ t ^ (t >> 8);
}

@ @<Check the range, try again if out of range, else |return|@>= {
  if(rng_w<=r) return rng_w%limit;
}

@ @<Cases for system commands@>=
  @-case 'u': {
    // Generate a random number
    if(stack_ptr->is_string) program_error("Type mismatch");
    stack_ptr->number=gen_random(stack_ptr->number);
    break;
  }@#

@*Stack Programming Language. Now we get to the part where the user can
enter a program, in order to control the features of this program. The
programming language used is like \.{dc}, but different.

@.dc@>

Subroutines are simply stored as strings in the |names| area, since they
are the same as registers.

@ Now we have the storage of registers. Registers 0 to 255 are stored in
this separate list, while other register values are just stored in the
|names| list. There is also a stack, which has storage of the same values
as registers can contain.

@d max_stack 0x1000

@<Typedefs@>=
typedef struct {
  boolean is_string;
  union @+{
    int number;
    unsigned char*text;
  }@+;
} register_value;

@ @<More elements of |name_data|@>=
  register_value value;

@ @<Global variables@>=
register_value registers[256];
register_value stack[max_stack];
register_value*stack_ptr=stack-1; // current top of stack element

@ Here are some codes for pushing and popping the stack.

@d pop_num() ((stack_ptr--)->number)

@-p inline void push_string(char*s) {
  ++stack_ptr;
  stack_ptr->is_string=1;
  stack_ptr->text=strdup(s);
}

@ @-p inline void push_num(int n) {
  ++stack_ptr;
  stack_ptr->is_string=0;
  stack_ptr->number=n;
}

@ @-p inline void stack_dup(void) {
  if((stack_ptr[1].is_string=stack_ptr->is_string)) {
    stack_ptr[1].text=strdup(stack_ptr->text);
  } @+else {
    stack_ptr[1].number=stack_ptr->number;
  }
  stack_ptr++;
}

@ @-p inline void stack_drop(void) {
  if(stack_ptr->is_string) free(stack_ptr->text);
  --stack_ptr;
}

@ @-p inline char*pop_string(void) {
  char*p=stack_ptr->text;
  stack_ptr->is_string=0; stack_ptr->text=0;
  --stack_ptr;
  return p;
}

@ Also, some subroutines are needed here in order to deal with registers.

For |fetch_code|, the string |"0[]+"| is returned if it is not a string,
generating a ``Type mismatch'' error when you try to run it.

@-p inline char*fetch_code(int r) {
  if(!(r&~0xFF)) {
    if(!registers[r].is_string) return "0[]+";
    return registers[r].text;
  } @+else {
    if(!name_info(r).value.is_string) return "0[]+";
    return name_info(r).value.text;
  }
}

@ @-p inline void fetch(int r) {
  register_value*v;
  if(!(r&~0xFF)) v=&(registers[r]);
  else v=&(name_info(r).value);
  (++stack_ptr)->is_string=v->is_string;
  if(v->is_string) {
    stack_ptr->text=strdup(v->text);
  } @+else {
    stack_ptr->number=v->number;
  }
}

@ @-p inline void store(int r) {
  register_value*v;
  if(!(r&~0xFF)) v=&(registers[r]);
  else v=&(name_info(r).value);
  if(v->is_string) free(v->text);
  v->is_string=stack_ptr->is_string;
  if(v->is_string) {
    v->text=stack_ptr->text;
  } @+else {
    v->number=stack_ptr->number;
  }
  --stack_ptr;
}

@ There is also a save stack. This save stack stores the saved values of
the registers |'0'| to |'9'|, so that you can have local variables in a
subroutine.

@<Global variables@>=
register_value save_stack[520];
register_value*save_stack_ptr=save_stack;

@ These codes deal with the save stack. Strings will be copied when
saving. When loading, strings that were previously in the registers will
be freed.

@<Save local registers to the save stack@>= {
  int i;
  for(i='0';i<='9';i++) {
    *save_stack_ptr=registers[i];
    if(registers[i].is_string)
      save_stack_ptr->text=strdup(save_stack_ptr->text);
    save_stack_ptr++;
  }
}

@ @<Load local registers from the save stack@>= {
  int i;
  for(i='9';i>='0';i--) {
    if(registers[i].is_string) free(registers[i].text);
    registers[i]=*--save_stack_ptr;
  }
}

@*Commands for Stack Programming Language. Finally, is the code where it
can be executed. The return value of this function indicates how many
levels should be exit when it is called.

@-p int execute_program(unsigned char*prog) {
  unsigned char*ptr=prog;
reset_execute_program:
  for(;*ptr;ptr++) {
    switch(*ptr) {
      @<Cases for literal data commands@>@;
      @<Cases for stack manipulation commands@>@;
      @<Cases for arithmetic commands@>@;
      @<Cases for flow-control commands@>@;
      @<Cases for register/table operation commands@>@;
      @<Cases for string commands@>@;
      @<Cases for condition/compare commands@>@;
      @<Cases for local registers commands@>@;
      @<Cases for system commands@>@;
      @-case '?': @<Do a diagnostics command@>@;@+break;
      @-case '=': @<Do a typesetting command@>@;@+break;
      default:
        if(*ptr>='0' && *ptr<='9') {
          @<Read a literal number and push to stack@>;
        } @+else if(0x80&*ptr) {
          @<Execute a subroutine code from the current character@>;
        }
        break;
    }
    if(stack_ptr<stack-1) program_error("Stack underflow");
    if(stack_ptr>stack+max_stack) program_error("Stack overflow");
  }
  return 0;
}

@ @<Cases for literal data commands@>=
  @-case '`': {
    // Literal ASCII character
    push_num(*++ptr);
    break;
  }@#
  @-case '[': {
    // Literal string
    @<Read a literal string and push to stack@>;
    break;
  }@#
  @-case '(': {
    // Literal name
    @<Read a literal name and push its number to the stack@>;
    break;
  }@#

@ @<Read a literal number and push to stack@>= {
  int n=0;
  while(*ptr>='0' && *ptr<='9') n=10*n+(*ptr++)-'0';
  --ptr;
  push_num(n);
}

@ @<Read a literal string and push to stack@>= {
  char*p=++ptr;
  int n=1;
  while(n && *ptr) {
    if(*ptr=='[') ++n;
    if(*ptr==']') --n;
    if(n) ptr++;
  }
  if(!*ptr) program_error("Unterminated string literal");
  *ptr=0;
  push_string(p);
  *ptr=']';
}

@ @<Read a literal name and push its number to the stack@>= {
  char*p=++ptr;
  while(*ptr && *ptr!=')') ptr++;
  if(!*ptr) program_error("Unterminated string literal");
  *ptr=0;
  push_num(find_name(p));
  *ptr=')';
}

@ @<Cases for stack manipulation commands@>=
  @-case 'D': {
    // Drop top item of stack
    stack_drop();
    break;
  }@#
  @-case 'c': {
    // Clears the stack, rendering it empty
    while(stack_ptr>=stack) stack_drop();
    break;
  }@#
  @-case 'd': {
    // Duplicates the value on top of the stack.
    stack_dup();
    break;
  }@#
  @-case 'r': {
    // Swaps the top two values on the stack
    stack_ptr[1]=stack_ptr[0];
    stack_ptr[0]=stack_ptr[-1];
    stack_ptr[-1]=stack_ptr[1];
    break;
  }@#

@ @<Cases for arithmetic commands@>=
  @-case '+': {
    // Add two numbers, or concatenate two strings
    if(stack_ptr->is_string) {
      @<Concatenate strings on the stack@>;
    }@+ else {
      int n=pop_num();
      if(stack_ptr->is_string)
        program_error("Type mismatch");
      stack_ptr->number+=n;
    }
    break;
  }@#
  @-case '-': {
    // Subtract two numbers, or compare two strings
    if(stack_ptr->is_string) {
      @<Compare strings on the stack@>;
    }@+ else {
      int n=pop_num();
      if(stack_ptr->is_string)
        program_error("Type mismatch");
      stack_ptr->number-=n;
    }
    break;
  }@#
  @-case '*': {
    // Multiply two numbers
    int n=pop_num();
    if(stack_ptr[0].is_string || stack_ptr[1].is_string)
      program_error("Number expected");
    stack_ptr->number*=n;
    break;
  }@#
  @-case '/': {
    // Divide two numbers
    int n=pop_num();
    if(stack_ptr[0].is_string || stack_ptr[1].is_string)
      program_error("Number expected");
    if(n==0) program_error("Division by zero");
    stack_ptr->number/=n;
    break;
  }@#
  @-case '%': {
    // Modulo of two numbers
    int n=pop_num();
    if(stack_ptr[0].is_string || stack_ptr[1].is_string)
      program_error("Number expected");
    if(n==0) program_error("Division by zero");
    stack_ptr->number%=n;
    break;
  }@#

@ @<Concatenate strings on the stack@>= {
  char*s=pop_string();
  char*q;
  if(!stack_ptr->is_string) program_error("Type mismatch");
  q=malloc(strlen(s)+strlen(stack_ptr->text)+1);
  strcpy(q,stack_ptr->text);
  strcpy(q+strlen(q),s);
  stack_drop();
  push_string(q);
  free(q);
  free(s);
}

@ @<Compare strings on the stack@>= {
  char*s=pop_string();
  char*q=pop_string();
  push_num(strcmp(q,s));
  free(q);
  free(s);
}

@ @<Cases for flow-control commands@>=
  @-case 'Q': {
    // Exit from multiple levels
    int q=pop_num();
    if(q>0) return q-1;
    break;
  }@#
  @-case 'Y': {
    // Go back to beginning
    ptr=prog-1;
    break;
  }@#
  @-case 'q': {
    // Exit from two levels
    return 1;
    break;
  }@#
  @-case 'x': {
    // Execute code from top of stack
    @<Execute a string or subroutine code from top of stack@>;
    break;
  }@#

@ Note here, it is a recursive function call.
@^recursive@>

@<Execute a string or subroutine code from top of stack@>= {
  if(stack_ptr->is_string) {
    char*p=pop_string();
    int q=execute_program(p);
    free(p);
    if(q) return q-1;
  } @+else {
    char*p=fetch_code(pop_num());
    int q=execute_program(p);
    if(q) return q-1;
  }
}

@ Since the extended characters (|0x80| to |0xFF|) do not correspond to
any commands, here we can use them to execute a subroutine code, allowing
many things related to self-modifying code (and other stuff) to be done
that would be difficult otherwise.

@<Execute a subroutine code from the current character@>= {
  char*p=fetch_code(*ptr);
  int q=execute_program(p);
  if(q) return q-1;
}

@ @<Cases for register/table operation commands@>=
  @-case ':': {
    // Store value to table
    int n;
    if(stack_ptr->is_string) program_error("Number expected");
    n=pop_num();
    tables[0x7F&*++ptr][n]=pop_num();
    break;
  }@#
  @-case ';': {
    // Load value from table
    stack_ptr->number=tables[0x7F&*++ptr][stack_ptr->number];
    break;
  }@#
  @-case 'L': {
    // Load value from register named by stack
    if(stack_ptr->is_string) program_error("Number expected");
    fetch(pop_num());
    break;
  }@#
  @-case 'S': {
    // Store value in register named by stack
    if(stack_ptr->is_string) program_error("Number expected");
    store(pop_num());
    break;
  }@#
  @-case 'l': {
    // Load value from register
    fetch(*++ptr);
    break;
  }@#
  @-case 's': {
    // Store value in register
    store(*++ptr);
    break;
  }@#

@ @<Cases for string commands@>=
  @-case 'B': {
    // Put brackets around a string, or convert number to text
    if(stack_ptr->is_string) {
      @<Put brackets around string at top of stack@>;
    } @+else {
      @<Convert top of stack to string representation of a number@>;
    }
    break;
  }@#
  @-case 'Z': {
    // Calculate number of characters in a string
    char*s=pop_string();
    push_num(strlen(s));
    free(s);
    break;
  }@#
  @-case 'a': {
    // ``ASCIIfy'' a number
    if(stack_ptr->is_string) {
      if(stack_ptr->text[0]) stack_ptr->text[1]=0;
    } @+else {
      int n=stack_ptr->number;
      stack_ptr->is_string=1;
      stack_ptr->text=malloc(2);
      stack_ptr->text[0]=n;
      stack_ptr->text[1]=0;
    }
    break;
  }@#
  @-case 'A': {
    // Take the first character from the string
    char*s=stack_ptr->text;
    if(!stack_ptr->is_string || !*s) return 0;
    push_num(*s);
    stack_ptr[-1].text=strdup(s+1);
    free(s);
    break;
  }@#
  @-case 'N': {
    // Convert a register number to its name
    int n=stack_ptr->number;
    if(stack_ptr->is_string) program_error("Type mismatch");
    if(n<256 || n>=names.used+256) program_error("Out of range");
    stack_drop();
    push_string(names.data[n-256].name);
    break;
  }@#

@ @<Put brackets around string at top of stack@>= {
  char*buf=malloc(strlen(stack_ptr->text)+3);
  sprintf(buf,"[%s]",stack_ptr->text);
  free(stack_ptr->text);
  stack_ptr->text=buf;
}

@ @<Convert top of stack to string representation of a number@>= {
  char buf[32];
  sprintf(buf,"%d",stack_ptr->number);
  stack_drop();
  push_string(buf);
}

@ Here is how the ``Arithmetic IF'' command works: On the stack you have
any three values at the top, and a number underneath it. Those are all
removed, except one of the three values which is selected based on the
sign of the number (the condition value).

@<Cases for condition/compare commands@>=
  @-case 'i': {
    // Arithmetic IF
    @<Do the ``Arithmetic IF''@>;
    break;
  }@#
  @-case '&': {
    // Bitwise AND
    int n=pop_num();
    if(stack_ptr[0].is_string || stack_ptr[1].is_string)
      program_error("Number expected");
    stack_ptr->number&=n;
    break;
  }@#

@ Do you like this algorithm? Is this a real question?

@^strange codes@>

@<Do the ``Arithmetic IF''@>= {
  register_value v=stack_ptr[-3];
  int n=v.number;
  n=-(n<0?2:!n);
  stack_ptr[-3]=stack_ptr[n];
  stack_ptr[n]=v;
  stack_drop();@+stack_drop();@+stack_drop();
}

@ @<Cases for local registers commands@>=
  @-case '<': {
    // Save locals
    @<Save local registers to the save stack@>;
    break;
  }@#
  @-case '>': {
    // Restore locals
    @<Load local registers from the save stack@>;
    break;
  }@#

@ When there is a program error (such as stack underflow), the following
subroutine is used to handle it.

@d program_error(_text) program_error_(prog,ptr,_text)

@-p void program_error_(char*prog,char*ptr,char*msg) {
  fprintf(stderr,"Error in %s on line %d",current_filename,current_line);
  fprintf(stderr,"\n! %s\ns%dS%dp%d near \"",msg,stack_ptr-stack,
   save_stack_ptr-save_stack,ptr-prog);
  @<Display the codes near the part that caused the error@>;
  fprintf(stderr,"\"\n");
  exit(1);
}

@ @<Display the codes near the part that caused the error@>= {
  char buf[32];
  char*p=ptr-5;
  int i;
  if(p<prog || p>ptr) p=prog;
  for(i=0;p+i<=ptr && p[i];i++) buf[i]=p[i];
  buf[i]=0;
  fprintf(stderr,"%s",buf);
}

@*Tables and Registers. The tables must be stored here. There are 128
tables with 256 entries each, each of which can store one byte of data.
These tables are used for converting uppercase/lowercase, for deciding
which characters need to be escaped in \TeX, and so on.

The purposes of the built-in registers are also described in this chapter.
The tables and registers named by uppercase letters are for system use.
The tables and registers named by lowercase can be used by the user.

@<Global variables@>=
unsigned char tables[128][256];

@ Here are the uses of the built-in tables and registers:
@^built-in registers@>
@^built-in tables@>

Register \.A: The current position in the current cards area.

Register \.C: The current cards area.

Register \.D: Dots per inch, multiplied by 100.

Register \.E: The escape character for \TeX. If this is a string, the
entire string is the prefix; otherwise, it is a ASCII number of the
character to be used.

Register \.K: Index number for last keyword entry added. Also used when
dealing with keyword operation commands, and when a keyword is matched in
a pattern.

Register \.P: The current pattern area.

Register \.Q: The parameters for the ImageMagick command-line, separated
by spaces.

Register \.T: Alignment tab character for \TeX. Same considerations apply
as the \.E register.

Register \.U: A code to execute for a deck specification enrty with \.x
flag set.

Register \.V: The version number of this program.

Register \.W: A code which pushes the whatsit replacements onto the stack.
It is initialized to a blank string before each line in a card area. It
should push the replacements in the reverse order of the whatsits, so you
could use a code like this, for example: \.{[(Abracadabra)]lW+sW}

Register \.X: Horizontal coordinate across the page (in pixels).

Register \.Y: Vertical coordinate across the page (in pixels).

Register \.Z: Should be set to a code to execute after doing everything
else (but before writing output files).

Table \.E: Indicates which characters need escaped for \TeX. Also used for
category codes in internal typesetting mode (a discussion of the category
codes will be deferred to a later part of this book).

Table \.F: Space factor codes for internal typesetting, where 40 is normal
(multiplying these values by 25 results in the corresponding \.{\\sfcode}
values in \TeX). Zero means no change.

Table \.G: Table containing information for sorting and grouping.

Table \.J: Left margin protrusions for internal typesetting. A value of
128 is normal. Each one unit less or greater than 128 represents a
distance of 0.005 em, where number less than 128 for negative kerns and
greater than 128 for positive kerns. (Note that you will use {\sl negative
negative} kerns to protrude into the margin, both for the left protrusions
and for the right protrusions!)

Table \.K: Right margin protrusions for internal typesetting.

Table \.L: Conversion to lowercase.

Table \.S: Information for natural sorting.

Table \.U: Conversion to uppercase.

Table \.W: Table for word form rules. Zero means a letter, one means a
word separator, two means use to mark beginning of a word, three means use
to mark the end of a word. In this program, it is advantageous to use the
fact that zero means word characters (such as letters), and nonzero means
nonword characters.

@d init_register(_reg,_val) do@+{
  registers[_reg].is_string=0;
  registers[_reg].number=(_val);
}@+while(0)@;
@#
@d init_register_str(_reg,_val) do@+{
  registers[_reg].is_string=1;
  registers[_reg].text=strdup(_val);
}@+while(0)@;

@<Initialize the tables and registers@>= {
  int i;
  for(i=0;i<256;i++) init_register(i,0);
  init_register('E','\\');
  init_register('V',version_number);
  @<Initialize table of alphabetical case conversion@>;
  @<Initialize tables for internal typesetting@>;
}

@ @<Initialize table of alphabetical case conversion@>= {
  for(i=0;i<256;i++) tables['L'][i]=tables['U'][i]=i;
  for(i='A';i<='Z';i++) {
    tables['L'][i]=i+'a'-'A';
    tables['U'][i+'a'-'A']=i;
  }
}

@ @<Display the contents of table |*++ptr|@>= {
  int t=*++ptr;
  int i;
  for(i=0;i<256;i++) {
    printf("%c%c",tables[t][i]?'+':'.',@|
      (tables[t][i]<0x7F && tables[t][i]>=' ')?tables[t][i]:'.'
    );
    if((i&0x0F)==0x0F) printf("\n");
  }
  for(i=' ';i<0x7F;i++) if(tables[t][i]) printf("%c",i);
}

@*Diagnostics. Here is diagnostics commands. These are used to display the
internal information on standard output, so that you can check how these
things are working. (You can also use \.{gdb} for debugging purposes.) A
diagnostics command always starts with a question mark, and is then
followed by one more character indicating the type of diagnostics
requestsed. (Some are followed by an additional character after that.)

@<Do a diagnostics command@>= {
  switch(*++ptr) {
    case 'c': @<Display the sorted card list@>; @+break;
    case 'd': @<Display the deck list@>; @+break;
    case 'f': @<Display font information@>; @+break;
    case 'k': @<Display the list of keywords@>; @+break;
    case 'n': @<Display the list of names@>; @+break;
    case 'p': @<Display the list of patterns@>; @+break;
    case 's': @<Display the contents of the stack@>; @+break;
    case 't': @<Display the contents of table |*++ptr|@>; @+break;
    case 'w': @<Display the list of word form rules@>; @+break;
    case 'x': @<Display the list of typeset nodes@>; @+break;
    case 'y': @<Display typesetting diagnostics@>; @+break;
    default: program_error("Unknown type of diagnostics");
  }
}

@ One subroutine is used here for displaying strings with escaped, so that
it will display on a terminal without messing it up or omitting the
display of some characters.

@-p void display_string(char*s) {
  for(;*s;s++) {
    if(*s<' ' || *s==0x7F) {
      printf("^%c",0x40^*s);
    } @+else {
      printf("%c",*s);
    }
  }
}

@ @<Display the contents of the stack@>= {
  register_value*p;
  for(p=stack;p<=stack_ptr;p++) {
    if(p->is_string) {
      printf("[");
      display_string(p->text);
      printf("]\n");
    } @+else {
      printf("%d\n",p->number);
    }
  }
}

@ More of the diagnostics functions are included in the chapters for the
data structures which it is displaying.

@*Pattern Matching. Now, finally, after the chapter about patterns, and
going through many other things in between, comes to the chapter in which
patterns are actually being matched.

One structure is used here for the information about how to match it, and
what has been matched from it. The parameter |num_capture| is how many
captured parts there are, and the |start| and |end| arrays store the index
into the |src| string of where the matches are. The entire matched part is
indicated by |start[0]| and |end[0]| (note always |start[0]==0|).

@<Typedefs@>=
typedef struct {
  char*src;
  char*truesrc; // used for checking true beginning of the line
  char*pattern;
  unsigned int category;
  int start[16];
  int end[16];
  int num_capture;
} match_info;

@ This first one just matches one pattern against a string to see if it
matches. It returns true if it does match. (It is somewhat inefficient.)

@-p boolean match_pattern(match_info*mat) {
  char*src; // current start of source string
  char*ptr; // pointer into source string |src|
  char*pptr; // pointer into pattern string
  src=mat->src; @+ mat->num_capture=0; @+ pptr=mat->pattern; @+ ptr=src;
  @<Execute the pattern on the string |src|@>;
  mismatch: return 0;
}

@ This loop executes each command in the pattern in attempt to match each
character. In case of mismatch, it will break out of this loop, and
continue with the next iteration of the loop in the previous section.

@d not_a_marker !(pptr[-1]&0x80)

@<Execute the pattern on the string |src|@>= {
  while(*pptr) {
    switch(*pptr++) {
      case begin_capture:
        mat->start[++mat->num_capture]=ptr-mat->src; @+break;
      case end_capture: mat->end[mat->num_capture]=ptr-mat->src; @+break;
      case match_keyword: @<Do |match_keyword|@>; @+break;
      case match_table:
        if(!tables[*pptr++][*ptr++]) goto mismatch; @+break;
      case optional_table: ptr+=!!tables[*pptr++][*ptr]; @+break;
      case failed_match: goto mismatch;
      case jump_table:
        if(!(pptr=strchr(mat->pattern,0x80|tables[*pptr++][*ptr++])))
          goto mismatch;
        @+break;
      case successful_match: @<Do |successful_match|@>;
      case back_one_space: if(ptr--==mat->src) goto mismatch; @+break;
      case forward_one_space: if(!*ptr++) goto mismatch; @+break;
      case match_left_side: if(ptr!=mat->truesrc) goto mismatch; @+break;
      case match_right_side: if(*ptr>=' ') goto mismatch; @+break;
      default: if(not_a_marker && pptr[-1]!=*ptr++) goto mismatch;
    }
  }
}

@ @<Do |successful_match|@>= {
  mat->start[0]=0;
  mat->end[0]=ptr-mat->src;
  return 1;
}

@ And now, the next part matches from an area and changes the string in
place, possibly by reallocating it. The |src| pointer passed to this
function should be one that can be freed!

@-p char*do_patterns(char*src,int area) {
  pattern_data*pat;
  match_info mat;
  int index=0; // index into |src| string
  @<Cancel if there isn't a pattern area@>;
continue_matching:
  if(index>=strlen(src)) return src;
  pat=pattern_areas.data+name_info(area).pattern_area;
  for(;;) {
    @<Fill up the |mat| structure for testing the current pattern@>;
    if(mat.pattern && match_pattern(&mat)) {
      @<Push the captured strings to the stack@>;
      @<Call the subroutine associated with this pattern@>;
      if(stack_ptr->is_string) {
        @<Replace the matched part from the stack and fix the |index|@>;
      } @+else {
        index+=mat.end[0];
      }
      stack_drop();
      goto continue_matching;
    }
    @<Select the next pattern in this area or |break|@>;
  }
  index++; @+ goto continue_matching;
}

@ @<Cancel if there isn't a pattern area@>= {
  if(area<256) return src;
  if(!name_info(area).has_pattern_area) return src;
}

@ @<Fill up the |mat| structure for testing the current pattern@>= {
  mat.src=src+index;
  mat.truesrc=src;
  mat.pattern=pat->text;
  mat.category=pat->category;
}

@ @<Push the captured strings to the stack@>= {
  int i;
  for(i=mat.num_capture;i;i--) {
    push_string(src+index+mat.start[i]);
    stack_ptr->text[mat.end[i]-mat.start[i]]=0;
  }
}

@ @<Call the subroutine associated with this pattern@>= {
  execute_program(names.data[pat->subroutine].value.text);
}

@ The memory allocated is probably more than is needed, but this way is
simpler. It is always sufficient amount, though. Think about it.

@^thought@>

@<Replace the matched part from the stack and fix the |index|@>= {
  char*q=malloc(strlen(src)+strlen(stack_ptr->text)+1);
  strcpy(q,src);
  sprintf(q+index,"%s%s",stack_ptr->text,src+index+mat.end[0]);
  free(src);
  src=q;
  index+=strlen(stack_ptr->text);
}

@ @<Select the next pattern in this area or |break|@>= {
  if(pat->next==none) break;
  pat=pattern_areas.data+pat->next;
}

@ Finally, there is a command |'M'| to do a pattern matching and
replacement with a string, inside of a stack subroutine code.

@<Cases for system commands@>=
  @-case 'M': {
    // do pattern matching and replacement
    int n=pop_num();
    if(!stack_ptr->is_string) program_error("Type mismatch");
    stack_ptr->text=do_patterns(stack_ptr->text,n);
    break;
  }@#

@*Matching Keywords. Codes for matching keywords have been placed in
another chapter, instead of making the previous chapter longer.

So now we can see how it is matched keywords in a pattern code.

@<Do |match_keyword|@>= {
  match_info m;
  char mstr[512];
  char t=*pptr++; // indicate which table to use
  data_index best=none;
  int best_length=-1;
  @<Try matching each keyword belonging to the category@>;
  if(best==none) goto mismatch;
  @<Adjust the \.K register for this keyword match@>;
  ptr+=m.end[0];
}

@ @<Adjust the \.K register for this keyword match@>= {
  if(registers['K'].is_string) free(registers['K'].text);
  registers['K'].is_string=0;
  registers['K'].number=best;
}

@ When matching keywords, all of them will be tried, in case there are
better candidates for the search (bigger is better (so, for example,
|"Power of One"| will override |"Power"|); failing that, later ones are
better than earlier ones (so that user files can override keywords in
template files)).

@^Courtenay, Bryce@>
@^Houghton, Israel@>
@^Luce, Ron@>

@<Try matching each keyword belonging to the category@>= {
  data_index i;
  foreach(i,keywords) {
    if(keywords.data[i].category&mat->category &&
     strlen(keywords.data[i].match)>=best_length) {
      @<Set up the |match_info| structure called |m|@>;
      @<Attempt applying this keyword match@>;
    }
  }
}

@ @<Set up the |match_info| structure called |m|@>= {
  sprintf(mstr,"%s%c%c%c",
    keywords.data[i].match,match_table,t,successful_match);
  m.src=m.truesrc=ptr;
  m.pattern=mstr;
}

@ @<Attempt applying this keyword match@>= {
  if(match_pattern(&m)) {
    best=i;
    best_length=strlen(keywords.data[i].match);
  }
}

@*Sorting and Grouping. The card lists can be sorted/grouped using these
commands, which are generally used by macros that create the records for
the cards in the card areas.

@<Cases for system commands@>=
  @-case 'n': {
    // Add a new list entry
    data_index n=new_record(card_list);
    card_list.data[n].token_ptr=
      card_areas.data[set_card_area(registers['C'].number)].used
    ;
    break;
  }@#
  @-case 'f': {
    // Set a field value of the list entry
    data_index n=card_list.used-1;
    int x=pop_num();
    int y=pop_num();
    if(n==none) program_error("No card list is available");
    card_list.data[n].field[x&31]=y;
    break;
  }@#

@ Other than the commands to make the list entries above, there must be,
of course, the actual sorting and grouping being done!

Sorting and grouping are controlled by the \.G table. Starting from a
given offset (added), you use thirty-two entries for the thirty-two
fields.

@<Cases for system commands@>=
  @-case 'G': {
    // Sort the list
    sorting_table_offset=pop_num();
    qsort(card_list.data,card_list.used,sizeof(list_entry),list_compare);
    @<Mark positions in the sorted list@>;
    break;
  }@#

@ @<Global variables@>=
int sorting_table_offset;

@ This is the compare function for the list sorting. It is also worth to
notice here what values belong in the \.G table. (There are also some
other values, which are described a bit later.)

@d no_sort 0
@d primary_ascending 'A'
@d primary_descending 'Z'
@d primary_name 'N'
@d secondary_ascending 'a'
@d secondary_descending 'z'
@d secondary_name 'n'
@d record_sorted_position 'R'
@d reset_high_bits 'q'
@#
@d G_table(_field) (tables['G'][((sorting_table_offset+(_field))&0xFF)])
@d p1s ((list_entry*)p1)
@d p2s ((list_entry*)p2)

@-p int list_compare(const void*p1,const void*p2) {
  @<Compare using fields indicated by \.G table@>;
  @<Compare using the card's name and the \.S table@>;
  @<Compare using the order in which the cards are typed in@>;
  return 0; // This can't, but will, happen.
}

@ @<Compare using fields indicated by \.G table@>= {
  int i;
  for(i=0;i<32;i++) if(p1s->field[i]!=p2s->field[i]) {
    if(G_table(i)==primary_ascending || (G_table(i)&0x80)) {
      return (p1s->field[i]>p2s->field[i])?1:-1;
    } @+else if(G_table(i)==primary_descending) {
      return (p1s->field[i]<p2s->field[i])?1:-1;
    } @+else if(G_table(i)==primary_name) {
      return name_compare(p1s->field[i],p2s->field[i]);
    }
  }
  for(i=0;i<32;i++) if(p1s->field[i]!=p2s->field[i]) {
    if(G_table(i)==secondary_ascending) {
      return (p1s->field[i]>p2s->field[i])?1:-1;
    } @+else if(G_table(i)==secondary_descending) {
      return (p1s->field[i]<p2s->field[i])?1:-1;
    } @+else if(G_table(i)==secondary_name) {
      return name_compare(p1s->field[i],p2s->field[i]);
    }
  }
}

@ When all else fails, \strike{play dead} use the order in which the cards
have been typed in. This is how it is made stable, and that you can get
the same results on any computer.

@^Smith, Steve@>

@<Compare using the order in which the cards...@>= {
  if(p1s->token_ptr>p2s->token_ptr) return 1;
  if(p1s->token_ptr<p2s->token_ptr) return -1;
}

@ The last thing to do after sorting, is mark positions in the list if it
is requested to do so.

In addition, it shall also optionally mark high bits (30 to 27) of some
fields, based on when other fields change. This helps with doing multi-%
dimensional statistics. The fields that it is based on will automatically
be primary sorted since such sorting is required for the marking algorithm
to work properly.

@<Mark positions in the sorted list@>= {
  data_index i;
  int j;
  for(j=0;j<32;j++) {
    if(G_table(j)==record_sorted_position) {
      foreach(i,card_list) card_list.data[i].field[j]=i;
    } @+else if(G_table(j)&0x80) {
      @<Mark high bits of fields to prepare for...@>;
    } @+else if(G_table(j)==reset_high_bits) {
      foreach(i,card_list) card_list.data[i].field[j]&=0x0FFFFFFF;
    }
  }
}

@ The rule is that whenever the current field's value changes, the bit in
the corresponding grouping field will be flipped. Since the statistics
grouping always treats consecutive equal values in the grouping field as
belonging to the same group, this is a way to insert ``group breaks'' into
the list.

@<Mark high bits of fields to prepare for complex statistics@>= {
  int f=G_table(j)&0x1F; // other field number
  int v=card_list.data[0].field[j]; // previous value
  int k=1<<(27+((G_table(j)&0x60)>>5)); // bit flip value
  int b=0; // current bit value
  foreach(i,card_list) {
    if(v!=card_list.data[i].field[j]) b^=k;
    card_list.data[i].field[f]&=~k;
    card_list.data[i].field[f]|=b;
    v=card_list.data[i].field[j];
  }
}

@ @<Display the sorted card list@>= {
  data_index i;
  int j;
  foreach(i,card_list) {
    printf("%d=[ ",card_list.data[i].token_ptr);
    for(j=0;j<32;j++) printf("%d ",card_list.data[i].field[j]);
    printf("]\n");
  }
}

@*Natural Sorting. A natural compare algorithm is used here. It is a
generalization of Martin Pool's algorithm\biblio{Pool, Martin. ``Natural
Order String Comparison''. {\tt
http://sourcefrog.net/projects/natsort/}.}.

The \.S table maps from character tokens to the sorting specifications.
Name tokens are converted to |whatsit| when looking up in this table.

Tokens are grouped into digits, letters, and priority letters. There are
also some extras, such as spaces and radix point. A string of consecutive
digits is treated as numeric, so a number with more digits comes after a
number with less digits.

Priority letters are used mainly for sorting roman numerals. Two or more
consecutive priority letters are considered as a group, otherwise they are
treated in the same way as ordinary letters. A group is ranked with the
letters latest in the alphabet, so for example, if |'I'| and |'X'| are
priority, then |"IX"| is placed between |"W"| and |"X"|. This way, all
roman numerals from I to XXXIX will be sorted correctly.

@^natural compare@>
@^Pool, Martin@>

@d nat_end_low 0
@d nat_end_high 1
@d nat_space 2
@d nat_ignore 3
@d nat_radix_point 4
@#
@d nat_digit_zero 64 // digits go up to 127
@d nat_first_letter 128 // letters go up to 191
@d nat_first_priority_letter 192 // priority letters go up to 255
@d nat_high_value 256

@<Compare using the card's name and the \.S table@>= {
  token*pa=card_areas.data[set_card_area(registers['C'].number)].tokens
   +p1s->token_ptr;
  token*pb=card_areas.data[set_card_area(registers['C'].number)].tokens
   +p2s->token_ptr;
  boolean fractional=0; // Are we reading digits after a radix point?
  int a,b,c;
  for(;;pa++,pb++) {
    begin_natural_compare_loop: @/
    a=tables['S'][*pa>=256?whatsit:*pa];
    @+ b=tables['S'][*pb>=256?whatsit:*pb];
    @<Skip over leading spaces and/or zeros@>;
    @<Process a run of digits@>;
    @<Check if the end of either string is reached@>;
    @<Check for a radix point@>;
    @<Process priority letters@>;
    @<Check if the current positions of each string sufficiently differ@>;
  }
}

@ @<Skip over leading spaces and/or zeros@>= {
  while(a==nat_space||a==nat_ignore||(!fractional&&a==nat_digit_zero)) {
    int aa=tables['S'][pa[1]>=256?whatsit:pa[1]];
    if(a!=nat_ignore) fractional=0;
    if(!fractional && a==nat_digit_zero
     && aa>=nat_digit_zero && aa<nat_first_letter) break;
    pa++; @+ a=tables['S'][*pa>=256?whatsit:*pa];
  }
  while(b==nat_space||b==nat_ignore||(!fractional&&b==nat_digit_zero)) {
    int bb=tables['S'][pa[1]>=256?whatsit:pa[1]];
    if(b!=nat_ignore) fractional=0;
    if(!fractional && b==nat_digit_zero
     && bb>=nat_digit_zero && bb<nat_first_letter) break;
    pb++; @+ b=tables['S'][*pb>=256?whatsit:*pb];
  }
}

@ @<Process a run of digits@>= {
  if(a>=nat_digit_zero&&a<nat_first_letter&&
   b>=nat_digit_zero&&b<nat_first_letter) {
    if((c=(fractional?compare_left:compare_right)(pa,pb))) return c;
    @<Skip the run of digits, since they are the same@>;
    fractional=0;
  }
}
@^strange codes@>

@ Compare two left-aligned numbers: the first to have a different value
wins. This function and |compare_right| are basically equivalent, there
are only a few differences (this one is the simpler one).

@-p int compare_left(token*pa,token*pb) {
  int a,b;
  for(;;pa++,pb++) {
    a=tables['S'][*pa>=256?whatsit:*pa];
    @+ b=tables['S'][*pb>=256?whatsit:*pb];
    @<Skip over ignored characters@>;
    @<If neither |a| nor |b| is digit, |break|@>;
    @<If one is a digit and the other isn't, the longest run wins@>;
    @<If both are different digits, the greater one wins@>;
  }
  return 0;
}

@ The longest run of digits wins. That aside, the greatest value wins, but
we can't know that it will until we've scanned both numbers to know they
have the same magnitude, so we remember it in |bias|.

@-p int compare_right(token*pa,token*pb) {
  int a,b;
  int bias=0;
  for(;;pa++,pb++) {
    a=tables['S'][*pa>=256?whatsit:*pa];
    @+ b=tables['S'][*pb>=256?whatsit:*pb];
    @<Skip over ignored characters@>;
    @<If neither |a| nor |b| is digit, |break|@>;
    @<If one is a digit and the other isn't, the longest run wins@>;
    @<If both are digits, set the |bias|@>;
  }
  return bias;
}

@ Ignored characters might be commas for grouping digits into thousands.

@<Skip over ignored characters@>= {
  while(a==nat_ignore) {
    pa++; @+ a=tables['S'][*pa>=256?whatsit:*pa];
  }
  while(b==nat_ignore) {
    pb++; @+ b=tables['S'][*pb>=256?whatsit:*pb];
  }
}

@ @<If neither |a| nor |b| is digit, |break|@>= {
  if(!(a>=nat_digit_zero&&a<nat_first_letter)&&
   !(b>=nat_digit_zero&&b<nat_first_letter)) break;
}

@ @<If one is a digit and the other isn't, the longest run wins@>= {
  if(!(a>=nat_digit_zero&&a<nat_first_letter)) return -1;
  if(!(b>=nat_digit_zero&&b<nat_first_letter)) return 1;
}

@ @<If both are different digits, the greater one wins@>= {
  if(a!=b) return a-b;
}

@ @<If both are digits, set the |bias|@>= {
  if(a!=b && !bias) bias=(a<b)?-1:1;
}

@ @<Skip the run of digits, since they are the same@>= {
  while(a>=nat_digit_zero&&a<nat_first_letter) {
    pa++; @+ pb++; @+ a=tables['S'][*pa>=256?whatsit:*pa];
  }
  b=tables['S'][*pb>=256?whatsit:*pb];
}

@ @<Check if the end of either string is reached@>= {
  if(a==nat_end_low && b>nat_end_high) return -1;
  if(b==nat_end_low && a>nat_end_high) return 1;
  if(a==nat_end_high && b>nat_end_high) return 1;
  if(b==nat_end_high && a>nat_end_high) return -1;
  if(a<=nat_end_high && b<=nat_end_high) break; // tied
}

@ A radix point must be followed by a digit, otherwise it is considered to
be punctuation (and ignored). Radix points come before digits in the
sorting order (|".5"| comes before |"5"|).

@<Check for a radix point@>= {
  if(a==nat_radix_point && b==nat_radix_point) {
    int aa=tables['S'][pa[1]>=256?whatsit:pa[1]];
    int bb=tables['S'][pb[1]>=256?whatsit:pb[1]];
    if(aa>=nat_digit_zero&&aa<nat_first_letter
     &&bb>=nat_digit_zero&&bb<nat_first_letter) fractional=1;
  } @+else if(a==nat_radix_point) {
    int aa=tables['S'][pa[1]>=256?whatsit:pa[1]];
    if(!(aa>=nat_digit_zero&&aa<nat_first_letter)) {
      pa++; goto begin_natural_compare_loop;
    }
  } @+else if(b==nat_radix_point) {
    int bb=tables['S'][pb[1]>=256?whatsit:pb[1]];
    if(!(bb>=nat_digit_zero&&bb<nat_first_letter)) {
      pb++; goto begin_natural_compare_loop;
    }
  }
}

@ This is used so that |"IX"| can be sorted between |"VIII"| and |"X"|. In
normal alphabetical order, |"IX"| sorts before |"V"|. This algorithm makes
it so that doesn't happen. For example: |a| is |'I'| and |aa| (the
character after |a| in the text) is |'X'| (the check |aa>a| ensures that
it too is priority, in addition to checking that |a| represents a negative
part of a roman number), and |b| is |'V'|. Now, since |'V'| comes between
|'I'| and |'X'| in the alphabetical order, the condition is checked to be
valid and it overrides the later check.

@<Process priority letters@>= {
  if(a>=nat_first_priority_letter) {
    int aa=tables['S'][pa[1]>=256?whatsit:pa[1]];
    if(aa>a && b>=nat_first_letter && (b&63)>(a&63) && (b&63)<(aa&63))
      return 1;
  }
  if(b>=nat_first_priority_letter) {
    int bb=tables['S'][pb[1]>=256?whatsit:pb[1]];
    if(bb>b && a>=nat_first_letter && (a&63)>(b&63) && (a&63)<(bb&63))
      return -1;
  }
}

@ At this point, |a| and |b| will both be |@[@]>=nat_radix_point|. Numbers
always come after letters (this rule is designed so that when a radix
point is found after a number, it will make a larger number; otherwise it
will be followed by a letter and therefore the one followed by the letter
is lesser since it has no fractional part to make it greater).

@<Check if the current positions of each string suffic...@>= {
  if(a>=nat_first_priority_letter) a-=64;
  if(b>=nat_first_priority_letter) b-=64;
  if(a<nat_first_letter) a+=128;
  if(b<nat_first_letter) b+=128;
  if(a!=b) return (a<b)?-1:1;
}

@*Name Sorting. This kind of sorting is used when items are grouped
together by some extra field in the statistics, such as creature types in
Magic: the Gathering.

It works in a similar way to the natural sorting algorithm, but this time
it is simpler and not as many things need to be checked. Digits and
priority letters are treated as normal letters, and the types |nat_space|,
|nat_ignore|, and |nat_radix_point| are all ignored. In addition, a null
terminator is always treated as |nat_end_low|.

If both names compare the same, their number is used instead, in order to
force sorting stability.

@-p int name_compare(int n1,int n2) {
  char*s1=name_info(n1).name;
  char*s2=name_info(n2).name;
  int a,b;
  for(;*s1 || *s2;s1++,s2++) {
    a=(*s1)?tables['S'][*s1]:nat_end_low;
    b=(*s2)?tables['S'][*s2]:nat_end_low;
    @<Skip over spaces and ignored characters@>;
    @<Check if the end of either string is reached@>;
    @<Check if the current positions of...@>;
  }
  return (n1<n2)?-1:1;
}

@ @<Skip over spaces and ignored characters@>= {
  while(a<nat_digit_zero) {
    s1++; @+ a=(*s1)?tables['S'][*s1]:nat_end_low;
  }
  while(b<nat_digit_zero) {
    s2++; @+ b=(*s2)?tables['S'][*s2]:nat_end_low;
  }
}

@*Statistics. After the card lists are created and sorted and grouped, it
can make statistics from them. It can be just a plain list, or it can be
in summary of groups, measuring count, minimum, maximum, mean, median, and
so on.

First we do the simple iteration.

@^mean@>
@^median@>
@^groups@>
@^minimum@>
@^maximum@>

@<Cases for system commands@>=
  @-case 'V': {
    // Iterate the card list
    data_index i;
    char*q=pop_string();
    if(!stack_ptr[1].is_string) program_error("Type mismatch");
    foreach(i,card_list) {
      push_num(card_list.data[i].token_ptr);
      store('A');
      execute_program(q);
    }
    free(q);
    break;
  }@#
  @-case 'v': {
    // Read a field from the card list
    int x=pop_num()&31;
    int y=0;
    data_index i;
    foreach(i,card_list) {
      if(registers['A'].number==card_list.data[i].token_ptr)
        y=card_list.data[i].field[x];
    }
    push_num(y);
    break;
  }@#

@ That was simple, see? Now to do gathering statistics of summary of
groups, which is a bit more complicated. The list is expected to be sorted
by the group field primary, and the statistics field ascending as
secondary, in order to make the correct calculation of the fields.

However, it will not do the sorting automatically, since there are some
reasons why you might want it to work differently. One thing you can do is
to sort the group field {\sl secondary} and some other more major group as
primary, in order to do two-dimensional statistics, and this will work as
long as you do not require the minimum, maximum, or median.

@<Cases for system commands@>=
  @-case 'g': {
    // Gather statistics of groups
    data_index i,si=0;
    int x=pop_num()&31; // field for grouping
    int y=pop_num()&31; // field to measure statistics with
    int sum1,sum2; // running totals of $s_1$ and $s_2$
    sum1=sum2=0;
    char*q=pop_string(); // code to execute for each group
    if(!stack_ptr[1].is_string) program_error("Type mismatch");
    foreach(i,card_list) {
      if(card_list.data[i].field[x]!=card_list.data[si].field[x]) {
        @<Send the results of the current group@>;
        sum1=sum2=0; @+ si=i;
      }
      @<Add to the running totals@>;
    }
    @<Send the results of the current group@>;
    free(q);
    break;
  }@#

@ Running totals are kept for two quantities called $s_1$ and $s_2$. There
is also $s_0$, but that can be calculated easily using subtraction, so
there is no need to keep a running total. If the sample values are denoted
$x_k$, the following equation represents the running totals:
$$s_j=\sum_{k=1}^N{x_k^j}$$ (note that $s_0=N$.)

@^mathematics@>

@<Add to the running totals@>= {
  sum1+=card_list.data[i].field[y];
  sum2+=card_list.data[i].field[y]*card_list.data[i].field[y];
}

@ Now we will send the results and call |q|. The results are sent to the
stack in the following order: $s_0$, $s_1$, $s_2$, $Q_0$, $2Q_2$, $Q_4$
(where $Q_0$ is the minimum, $Q_2$ the median, and $Q_4$ the maximum).

From these results, it is then possible to calculate the standard
deviation: $$\sigma={1\over s_0}\sqrt{s_0s_2-s_1^2}$$ and
$$s=\sqrt{s_0s_2-s_1^2\over s_0(s_0-1)}.$$

@^mathematics@>

@<Send the results of the current group@>= {
  push_num(i-si); // $s_0$
  push_num(sum1); // $s_1$
  push_num(sum2); // $s_2$
  push_num(card_list.data[si].field[y]); // $Q_0$
  push_num(
    card_list.data[(si+i)/2].field[y]+card_list.data[(si+i+1)/2].field[y]
  ); // $2Q_2$
  push_num(card_list.data[i-1].field[y]); // $Q_4$
  @# push_num(card_list.data[si].token_ptr); @+ store('A');
  execute_program(q);
}

@*Random Pack Generation. Now the codes so that it can create random packs
(such as booster packs) by using the card lists and deck lists.

A command |'P'| is used for evaluation of a deck list. It expects the deck
list number and the code to execute for each card on the list.

@^booster pack@>

@<Cases for system commands@>=
  @-case 'P': {
    // Generate a random pack or deck
    data_index s=set_deck_list(pop_num());
    data_index n; // current deck list entry
    if(stack_ptr[1].is_string) program_error("Number expected");
    @<Figure out what cards belong in the pack@>;
    @<Execute the code on the stack for each card in the pack@>;
    break;
  }@#

@ @<Figure out what cards belong in the pack@>= {
  deck_entry*e;
  int tries=1000; // How many times can you retry if it fails?
  figure_out_again:
  if(!--tries) program_error("No cards matched the deck criteria");
  n=s;
  @<Reset |amount_in_pack| of each card to zero@>;
  while(n!=none && (n=(e=deck_lists.data+n)->next)!=none)
    @<Process this deck entry@>;
}

@ @<Reset |amount_in_pack| of each card to zero@>= {
  data_index i;
  foreach(i,card_list) card_list.data[i].amount_in_pack=0;
}

@ The deck entry must be processed according to the flags. Here is a list
of flags:

\.a: Use all cards that meet the criteria, instead of only one. If this is
the case, it is possible to use negative weights to remove cards from the
pack. Also, it cannot fail.
[Combine with \.{x}]

\.k: Select without replacement. It is fail if the total weight is not
enough. There are two ways in which this differs from \.u (below). One is
that the previous lines in the deck list are not used. The other one is
that if the weight is more than one, there will be more than one ball for
that card, therefore the same card can be picked up multiple times.
[Combine with \.{sux}]

\.n: Use the |amount| as a probability. If |amount<=100| then the
probability is |amount/100| otherwise it is |100/amount|. This is a
probability of using the |name| to select another deck list instead of
this one.
[Combine with nothing]

\.s: Skip the next line if this line does not fail. (Normally, if one line
fails, everything does, and you have to try again.)
[Combine with \.{kux}]

\.u: Require unique selection. It is fail if the card is already in this
pack.
[Combine with \.{ksx}]

\.x: Pass the |name| as a string to the code in the \.U register, and then
use the resulting code as the code to determine weights instead of using
the code in the register named by |name| directly. Now you can type things
such as |"12x Forest"| into your deck list.
[Combine with \.{aksu}]

@<Process this deck entry@>= {
  if(e->flags&lflag('n')) {
    @<Determine whether or not to skip to another deck list@>;
  } @+else {
    char*c; // code for weights of each card
    int total; // total weight of cards
    data_index*bag=malloc(sizeof(data_index));
    @<Get the code |c| for the weights of each card@>;
    @<Calculate the weights of each card@>;
    if(!(e->flags&lflag('a')))
      @<Select some of the cards at random and add them to the pack@>;
    if(e->flags&lflag('x')) free(c);
    free(bag);
  }
}

@ @<Determine whether or not to skip to another deck list@>= {
  boolean q;
  if(e->amount<=100) {
    q=(gen_random(100)<e->amount);
  } @+else {
    q=(100<gen_random(e->amount));
  }
  if(q) n=set_deck_list(find_name(e->name));
}

@ @<Get the code |c| for the weights of each card@>= {
  if(e->flags&lflag('x')) {
    execute_program(registers['U'].text);
    if(stack_ptr->is_string) {
      c=pop_string();
    } @+else {
      program_error("Type mismatch");
    }
  } @+else {
    int n=find_name(e->name);
    if(name_info(n).value.is_string) {
      c=name_info(n).value.text;
    } @+else {
      program_error("Type mismatch");
    }
  }
}

@ @<Calculate the weights of each card@>= {
  data_index i;
  foreach(i,card_list) {
    registers['A'].number=card_list.data[i].token_ptr;
    execute_program(c);
    if(stack_ptr->number) {
      if(e->flags&lflag('a')) {
        card_list.data[i].amount_in_pack+=e->amount*stack_ptr->number;
      } @+else if(stack_ptr->number>0) {
        @<Add the cards to the |bag|@>;
      }
    }
    stack_drop();
  }
}

@ The |bag| is like, you put the balls in the bag so that you can mix it
and take one out, whatever number is on the ball is the card you put into
the pack. Except, that there is no balls and no bag.

There is one ball per point of weight.

@^balls@>

@<Add the cards to the |bag|@>= {
  int j=stack_ptr->number;
  bag=realloc(bag,(total+j)*sizeof(data_index));
  while(j--) bag[total+j]=i;
  total+=stack_ptr->number;
}

@ If it is not a line which adds all possibilities at once, then the cards
must be selected from the |bag| at random to bag them. In some cases it
will fail.

@<Select some of the cards at random and add them to the pack@>= {
  data_index r;
  int amount=e->amount;
  bag_next:
  if(!total) @<Deal with bag failure@>;
  r=gen_random(total);
  if((e->flags&lflag('u')) && card_list.data[bag[r]].amount_in_pack) {
    bag[r]=bag[--total];
    goto bag_next;
  }
  card_list.data[bag[r]].amount_in_pack++;
  if(e->flags&lflag('k')) bag[r]=bag[--total];
  if(amount--) goto bag_next;
  @#if(e->flags&lflag('s')) n=deck_lists.data[n].next;
  bag_done: ;
}

@ @<Deal with bag failure@>= {
  if(e->flags&lflag('s')) goto bag_done;
  else goto figure_out_again;
}

@ Now it must do stuff using the list which is generated. The quantity for
how many of that card is pushed on the stack, and this is done even for
cards with negative quantity (but not for zero quantity).

@<Execute the code on the stack for each card in the pack@>= {
  data_index i;
  char*q=pop_string();
  if(!stack_ptr[1].is_string) program_error("Type mismatch");
  foreach(i,card_list) {
    if(card_list.data[i].amount_in_pack) {
      push_num(card_list.data[i].amount_in_pack);
      execute_program(q);
    }
  }
  free(q);
}

@*Reading Input Files. Now it is time for the part of the program where
input files are read and processed. The areas of the file (and other
special commands) are indicated using \.@@ signs.

At first we have state information. Each state is labeled by uppercase
letters, or by digits 1 to 9. The high bit is set for the heading state,
meaning the first line that contains the name and/or other heading
information.

@d null_state 0
@d card_state 'C'
@d deck_state 'D'
@d execute_state 'E'
@d file_state 'F'
@d include_state 'I'
@d keyword_state 'K'
@d image_state 'M'
@d pattern_state 'P'
@d subroutine_state 'S'
@d font_state 'T'
@d encoding_state 'U'
@d wordforms_state 'W'
@d heading 0x80

@<Global variables@>=
int cur_state;
data_index cur_name;
data_index cur_data;
boolean omit_line_break;

@ The next thing that must be kept track of for input files is the stack
of open input files.

@d max_pathname_length 128
@d max_filename_length 128
@d max_input_stack 128
@d max_line_length 256

@<Typedefs@>=
typedef struct {
  FILE*fp; // zero for terminal input
  char name[max_filename_length+1];
  int line;
} input_file_data;

@ @<Global variables@>=
input_file_data input_files[max_input_stack];
input_file_data*current_input_file=input_files;
char input_buffer[max_line_length];

@ Some macros are useful to access the current file data.

@d current_line (current_input_file->line)
@d current_filename (current_input_file->name)
@d current_fp (current_input_file->fp)
@#
@d parsing_error(_text) fprintf(stderr,"%s on line %d in %s\n",
 _text,current_line,current_filename)@;

@ There is also conditional processing directives, which uses a single
variable to keep track of the level. If it is greater than zero, the
condition is false, and it is increased for nesting conditions (the
nested conditions have no truth to them).

@<Global variables@>=
int condition_level=0;

@ This subroutine inputs the next line. True is returned if there is a
line, or false if it is finished.

It is necessary to check for end of file and if so, close that file and
try the one it was included from; and if it is terminal input, display the
current state when prompting input from the user.

@-p boolean input_line(void) {
  input_line_again: if(current_fp) {
    @<Get a line of input from the file@>;
  } @+else {
    @<Get a line of terminal input@>;
  }
  @<Remove trailing |'\n'|, |'\r'|, and spaces@>;
  ++current_line;
  return 1;
}

@ @<Get a line of input from the file@>= {
  if(!fgets(input_buffer,max_line_length,current_fp)) {
    memusage_log("Closing input file",current_input_file-input_files)@;
    fclose(current_fp);
    if(current_input_file>input_files) {
      --current_input_file;
      goto input_line_again;
    } @+else {
      return 0;
    }
  }
}

@ @<Get a line of terminal input@>= {
  printf("\n%c> ",cur_state?cur_state:'>');
  fflush(stdout);
  if(!fgets(input_buffer,max_line_length,stdin)) return 0;
}

@ This function is used to open the main input file.

@-p void open_input(char*name) {
  if(++current_input_file>input_files+max_input_stack) {
    fprintf(stderr,"Too many simultaneous input files\n");
@.Too many simultaneous...@>
    exit(1);
  }
  memusage_log("Opening input file",current_input_file-input_files)@;
  strcpy(current_filename,name);
  current_line=0;
  current_fp=fopen(name,"r");
  if(!current_fp) {
    fprintf(stderr,"Cannot open input file: %s\n",name);
@.Cannot open input file@>
    exit(1);
  }
}

@ Trailing newlines and spaces are removed. On some computers, there will
be a carriage return before the line feed, it should be removed, so that
the same file will work on other computers, too.

@d last_character_input input_buffer[strlen(input_buffer)-1]

@<Remove trailing |'\n'|, |'\r'|, and spaces@>= {
  if(last_character_input=='\n') last_character_input=0;
  if(last_character_input=='\r') last_character_input=0;
  while(last_character_input==' ') last_character_input=0;
}

@ The input states start at these values.

@<Initialize the input states@>= {
  cur_state=execute_state;
  cur_name=cur_data=0;
}

@ Now it is the time to do the actual processing according to the contents
of the lines of the file. A line starting with \.@@ sign will indicate a
special command (to operate in all modes) or a mode switch command.

@d delete_chars(_buf,_c) memmove((_buf),(_buf)+(_c),strlen((_buf)+(_c))+1)

@<Process the input files@>= {
  char*buf;
  while(input_line()) {
    buf=input_buffer;
    if(condition_level) {
      buf+=strspn(buf," ");
      condition_level+=!strcmp(buf,"@@<");
      condition_level-=!strcmp(buf,"@@>");
    } @+else {
      omit_line_break=1;
      @<Convert \.@@ commands in the |input_buffer|@>;
      omit_line_break=0;
      process_line(buf);
    }
  }
}

@ @<Convert \.@@ commands in the |input_buffer|@>= {
  char*ptr=input_buffer;
  while(*ptr) {
    if(*ptr=='@@') {
      @<Convert the current \.@@ command@>;
    } @+else {
      ptr++;
    }
  }
}

@ @<Convert the current \.@@ command@>= {
  switch(*++ptr) {
    case '@@': @/
      delete_chars(ptr,1);
      break;
    case '.': @<Process \.{@@.} command@>;@+break;
    case '&': @<Process \.{@@\&} command@>;@+break;
    case '^': @<Process \.{@@\^} command@>;@+break;
    case '(': @<Process \.{@@(} command@>;@+break;
    case '<': @<Process \.{@@<} command@>;@+break;
    case '>': @<Remove this command from the input@>;@+break;
    default: @/
      if((*ptr>='A' && *ptr<='Z') || (*ptr>='0' && *ptr<='9')) {
        @<Enter a |heading| state@>;
      } @+else {
        parsing_error("Unknown @@ command");
      }
  }
}

@ @<Remove this command from the input@>= {
  ptr--;
  delete_chars(ptr,2);
}

@ Heading states are used for the first line of a section in the file.
After that line is processed, it becomes the corresponding non-heading
state |(cur_state&~heading)|.

Note: The state |'0'| is deliberately unused; you might use it for
documentation areas, for example.

@^documentation areas@>

@<Enter a |heading| state@>= {
  cur_state=heading|*ptr--;
  delete_chars(ptr,2);
  while(*ptr==' ' || *ptr=='\t') delete_chars(ptr,1);
}

@ @-p void process_line(char*buf) {
  int q=cur_state;
  cur_state&=~heading;
  switch(q) {
    case card_state: @<Process card state@>;@+break;
    case deck_state: @<Process deck state@>;@+break;
    case execute_state: @<Process execute state@>;@+break;
    case file_state: @<Process file state@>;@+break;
    case keyword_state: @<Process keyword state@>;@+break;
    case keyword_state: @<Process image state@>;@+break;
    case pattern_state: @<Process pattern state@>;@+break;
    case subroutine_state: @<Process subroutine state@>;@+break;
    case wordforms_state: @<Process word forms state@>;@+break;
    case card_state|heading: @<Process card heading@>;@+break;
    case deck_state|heading: @<Process deck heading@>;@+break;
    case file_state|heading: @<Process file heading@>;@+break;
    case include_state|heading: @<Process include heading@>;@+break;
    case keyword_state|heading: @<Process keyword heading@>;@+break;
    case image_state|heading: @<Process image heading@>;@+break;
    case pattern_state|heading: @<Process pattern heading@>;@+break;
    case subroutine_state|heading: @<Process subroutine heading@>;@+break;
    default: ; // nothing happens
  }
}

@ Sometimes you might want a macro which can send a line programmatically.
So, here is the way that it is done.

@<Cases for system commands@>=
  @-case 'X': {
    // Process a line by programming
    int n;
    if(stack_ptr->is_string) program_error("Type mismatch");
    n=pop_num();
    if(n) cur_state=n|heading;
    if(!stack_ptr->is_string) program_error("Type mismatch");
    omit_line_break=1;
    process_line(stack_ptr->text);
    stack_drop();
    break;
  }@#

@*Inner Commands. These are commands other than the section headings.

@ The first command to deal with is simple--it is a comment. The rest of
the current line is simply discarded.

@<Process \.{@@.} command@>= {
  ptr[-1]=0;
}

@ This command is a pattern split. It means it will process the part of
the line before this command and then process the stuff after it. The
variable |omit_line_break| is 1 if this command is used; because it means
there will not be a line break. (Otherwise, patterns and so on are split
at line breaks.)

@<Process \.{@@\&} command@>= {
  ptr[-1]=0;
  process_line(buf);
  buf=++ptr;
}

@ This allows control characters to be inserted into the input. This code
takes advantage of the way the ASCII code works, in which stripping all
but the five low bits can convert a letter (uppercase or lowercase) to its
corresponding control character.

@^control character@>

@<Process \.{@@\^} command@>= {
  ptr[1]&=0x1F;
  --ptr;
  delete_chars(ptr,2);
}

@ The following command is used to execute a code in a different state and
then include the results in this area.

@<Process \.{@@(} command@>= {
  char*p;
  char*q;
  @<Skip over the name and save the rest of the line@>;
  @<Execute the code for the named subroutine@>;
  @<Insert the returned string and fix the line buffer@>;
}

@ @<Skip over the name and save the rest of the line@>= {
  p=ptr+1;
  while(*ptr && *ptr!=')') ptr++;
  q=strdup(ptr+!!*ptr);
  *ptr=0;
}

@ @<Execute the code for the named subroutine@>= {
  int n=find_name(p);
  execute_program(fetch_code(n));
}

@ @<Insert the returned string and fix the line buffer@>= {
  char*s=pop_string();
  sprintf(p-2,"%s%s",s,q);
  ptr=p+strlen(s)-2;
  free(s);
  free(q);
}

@ This command is used for conditional processing. The condition value
comes from the stack. Zero is false, everything else is true.

@<Process \.{@@<} command@>= {
  --ptr;
  delete_chars(ptr,2);
  condition_level=!stack_ptr->number;
  stack_drop();
}

@*Card State. Cards are added to the card areas by using the card state.
The \.C register tells which is the current card area, and \.P register is
used to select the current pattern area. The pattern area is used to match
patterns after reading a line. Please note that it won't work to change
the value of the \.C register during the card state.

@<Process card heading@>= {
  int n=find_name(buf);
  cur_data=set_card_area(n);
  cur_name=n-256;
  push_num(n);@+store('C');
}

@ @<Process card state@>= {
  char*b;
  if(!omit_line_break) strcpy(buf+strlen(buf),"\n");
  @<Initialize the \.W register@>;
  b=do_patterns(strdup(buf),registers['P'].number);
  if(registers['W'].is_string) execute_program(registers['W'].text);
  @<Send the tokens of |b| and replace whatsits@>;
  free(b);
}

@ @<Initialize the \.W register@>= {
  if(registers['W'].is_string) free(registers['W'].text);
  registers['W'].is_string=1;
  registers['W'].text=strdup("");
}

@ @<Send the tokens of |b| and replace whatsits@>= {
  char*p;
  for(p=b;*p;p++) {
    if(*p==whatsit) {
      send_token(cur_data,pop_num());
    } @+else {
      send_token(cur_data,(*p==1)?0:*p);
    }
  }
}

@ There is one command you might want to send tokens in any other time.

@<Cases for system commands@>=
  @-case 'T': {
    // Add tokens to the card area
    if(stack_ptr->is_string) {
      @<Send tokens from the string on the stack@>;
    } @+else {
      send_token(set_card_area(registers['C'].number),stack_ptr->number);
    }
    stack_drop();
    break;
  }@#

@ @<Send tokens from the string on the stack@>= {
  char*p;
  data_index q=set_card_area(registers['C'].number);
  for(p=stack_ptr->text;*p;p++) send_token(q,*p);
}

@*Deck State. Deck state is used for creating deck lists and random packs.

@<Process deck heading@>= {
  cur_name=find_name(buf)-256;
  cur_data=set_deck_list(cur_name+256);
  @<Skip to the end of the deck list@>;
}

@ @<Skip to the end of the deck list@>= {
  while(deck_lists.data[cur_data].next!=none)
    cur_data=deck_lists.data[cur_data].next;
}

@ Now to parse each line in turn. Each line consists of a number, the
flags, and a text.

@<Process deck state@>= {
  int n=strtol(buf,&buf,10);
  unsigned int f=0;
  if(n) {
    buf+=strspn(buf,"\x20\t");
    @<Read the flags for the deck list@>;
    buf+=strspn(buf,"\x20\t"); // Now we are at the point of the text
    @<Send this line to the deck list@>;
    @<Create and advance to the new terminator of the deck list@>;
  }
}

@ @<Read the flags for the deck list@>= {
  while(*buf>='a' && *buf<='z') f |=lflag(*buf++);
  buf++; // Skip terminator of flags
}

@ If the \.x flag is set, it will be determined what to do with the text
by the user-defined code. Otherwise, it is always a name, so we can save
memory by pointing to the name buffer (since name buffers never vary).

@<Send this line to the deck list@>= {
  if(f&lflag('x')) {
    deck_lists.data[cur_data].name=strdup(buf);
  } @+else {
    deck_lists.data[cur_data].name=name_info(find_name(buf)).name;
  }
}

@ @<Create and advance to the new terminator of the deck list@>= {
  data_index i=new_record(deck_lists);
  deck_lists.data[cur_data].next=i;
  deck_lists.data[cur_data=i].next=none;
}

@*Execute State. This state is simple, just execute stack codes. It is the
initial state; you can use it with terminal input, too.

@<Process execute state@>= {
  execute_program(buf);
}

@*File State. This state is used to make list of output files. Each one is
stored as a string, like subroutine state. The difference is that newlines
will not be discarded. The other difference is that there is a flag in the
|name_data| record for it that tells it that it is a file that should be
sent to output.

@<More elements of |name_data|@>=
  boolean is_output_file;

@ @<Process file heading@>= {
  cur_name=find_name(buf)-256;
  if(!names.data[cur_name].value.is_string) {
    names.data[cur_name].value.is_string=1;
    names.data[cur_name].value.text=strdup("");
    names.data[cur_name].is_output_file=1;
  }  
}

@ @<Process file state@>= {
  int z=strlen(names.data[cur_name].value.text);
  if(!omit_line_break) strcpy(buf+strlen(buf),"\n");
  names.data[cur_name].value.text=realloc(names.data[cur_name].value.text,
    z+strlen(buf)+1);
  strcpy(names.data[cur_name].value.text+z,buf);
}

@*Include State. The include state causes inclusion of another source file
from this one.

@<Process include heading@>= {
  cur_state=execute_state;
  @<Push the include file onto the input stack@>;
  @<Attempt to open the include file...@>;
}

@ @<Push the include file onto the input stack@>= {
  ++current_input_file;
  memusage_log("Opening input file",current_input_file-input_files)@;
  strcpy(current_filename,buf);
  current_line=0;
  current_fp=0;
}

@ Include files are searched using the search path specified in the
environment variable called \.{TEXNICARDPATH}, which is a list of paths
delimited by colons on UNIX systems (including Cygwin), but semicolons on
Windows (colons are used in Windows for drive letters). A forward slash is
the path separator. Please note that if you want to use include files in
the current directory, you must include |"."| as the first entry in the
search path!!

@^search path@>
@.TEXNICARDPATH@>
@^Windows@>

@<Set |includepath_separator| depending on operating system@>=
#ifdef WIN32
#define @!includepath_separator ';'
#else
#define includepath_separator ':'
#endif

@ @<Attempt to open the include file by finding it in the search path@>= {
  current_fp=open_file(current_filename,"r");
  @<It is a fatal error if no such file was found@>;
}

@ Since this part of the code is activated in many parts of the program,
we will make it a subroutine that can open files in different modes.

@-p FILE*open_file(char*filename,char*mode) {
  char searchpath[max_pathname_length+max_filename_length+1];
  char*cpath;
  char*npath=getenv("TEXNICARDPATH");
  FILE*fp=0;
  strcpy(searchpath,npath?npath:".");
  npath=cpath=searchpath;
  @<Set |includepath_separator| depending on operating system@>;
 @<Attempt to open the file from each each directory in the search path@>;
  return fp;
}

@ @<Attempt to open the file from each each directory...@>= {
  while(!fp) {
    char f[max_pathname_length+max_filename_length+1];
    @<Select the next path name into |cpath| and |npath|@>;
    sprintf(f,"%s/%s",cpath,filename);
    fp=fopen(f,mode);
  }
}

@ @<Select the next path name into |cpath| and |npath|@>= {
  if(!(cpath=npath)) break;
  if((npath=strchr(npath,includepath_separator))) *npath++=0;
}

@ @<It is a fatal error if no such file was found@>= {
  if(!current_fp) {
    fprintf(stderr,"%s not found in search path.\n",current_filename);
@.not found in search path@>
    exit(1);
  }
}

@*Keyword State. You can add keywords to the keyword area by using this.
Each keyword heading is one entry in the list.

@<Process keyword heading@>= {
  cur_data=new_record(keywords);
  keywords.data[cur_data].match=strdup(buf);
  keywords.data[cur_data].replacement=strdup("");
}

@ @<Process keyword state@>= {
  keyword_data*k=&keywords.data[cur_data];
  if(*buf=='+') {
    k->category|=find_category(buf+1);
  } @+else {
    if(!omit_line_break) strcpy(buf+strlen(buf),"\n");
    @<Append buffer to keyword text@>;
  }
}

@ @<Append buffer to keyword text@>= {
  if(*buf) {
    int z=strlen(k->replacement);
    k->replacement=realloc(k->replacement,z+strlen(buf)+1);
    strcpy(k->replacement+z,buf);
  }
}

@*Image State. This state compiles image manipulator commands.

@<Process image heading@>= {
  int n=find_name(buf);
  cur_data=set_image_manip(n);
  cur_name=n-256;
}

@ Each line will be executed and then the numbers on the stack are used as
the command codes. This means you can also use names and calculations and
so on, instead of always entering the commands directly.

@<Process image state@>= {
  register_value*p=stack_ptr;
  execute_program(buf);
  if(stack_ptr<p) {
    fprintf(stderr,"Stack underflow\n");
    exit(1);
  }
  if(stack_ptr>p) {
    @<Get the numbers from the stack, store at image manipulation area@>;
    while(stack_ptr>p) stack_drop();
  }
}

@ @<Get the numbers from the stack, store at image manipulation area@>= {
  register_value*s=stack_ptr;
  int i=0;
  image_manipulator*im=image_manips.data+cur_data;
  while(im->next!=none) im=image_manips.data+im->next;
  im->data=malloc((im->data_len=s-p)*sizeof(unsigned short));
  for(;s<p;s++,i++) im->data[i]=s->number;
}

@*Pattern State. This state compiles patterns into a pattern area. It
uses its own syntax, and then is converted into the proper control codes
for the |text| of a pattern.

@<Process pattern heading@>= {
  cur_name=find_name(buf)-256;
  cur_data=set_pattern_area(cur_name+256);
}

@ The stuff inside the pattern state has its own commands.

@<Process pattern state@>= {
  char add_buf[1024]; // buffer of text to add to the current pattern
  pattern_data*pat=&pattern_areas.data[cur_data];
  *add_buf=0;
  switch(*buf) {
    case '<': @<Create a new pattern with top priority@>;@+break;
    case '>': @<Create a new pattern with bottom priority@>;@+break;
    case ':': @<Make a pattern text with a marker@>;@+break;
    case '+': @<Add a keyword category to this pattern@>;@+break;
    default: ; // do nothing
  }
  @<Append contents of |add_buf| to the pattern, if needed@>;
}

@ @<Create a new pattern with top priority@>= {
  cur_data=new_record(pattern_areas);
  pattern_areas.data[cur_data].text=strdup("");
  pattern_areas.data[cur_data].subroutine=find_name(buf+1)-256;
  pattern_areas.data[cur_data].next=names.data[cur_name].pattern_area;
  names.data[cur_name].pattern_area=cur_data;
}

@ @<Create a new pattern with bottom priority@>= {
  data_index n;
  cur_data=new_record(pattern_areas);
  pattern_areas.data[cur_data].text=strdup("");
  pattern_areas.data[cur_data].subroutine=find_name(buf+1)-256;
  pattern_areas.data[cur_data].next=none;
  @<Find the bottom pattern and store its index in |n|@>;
  pattern_areas.data[n].next=cur_data;
}

@ @<Find the bottom pattern and...@>= {
  n=names.data[cur_name].pattern_area;
  while(pattern_areas.data[n].next!=none && pattern_areas.data[n].text &&
   pattern_areas.data[pattern_areas.data[n].next].next!=none)
    n=pattern_areas.data[n].next;
}

@ Actually, the name of this \strike{cake} chunk is a lie, because it does
not always add a marker.

@<Make a pattern text with a marker@>= {
  char*p;
  char*b=add_buf;
  @<Add the pattern marker if applicable@>;
  for(p=buf+2;p[-1] && *p;p++) {
    switch(*p) {
      case '\\': *b++=*++p; @+break;
      case '(': *b++=begin_capture; @+break;
      case ')': *b++=end_capture; @+break;
      case '%': *b++=match_keyword; @+*b++=*++p; @+break;
      case '!': *b++=match_table; @+*b++=*++p; @+break;
      case '?': *b++=optional_table; @+*b++=*++p; @+break;
      case '#': *b++=failed_match; @+break;
      case '&': *b++=jump_table; @+*b++=*++p; @+break;
      case ';': *b++=successful_match; @+break;
      case '<': *b++=back_one_space; @+break;
      case '>': *b++=forward_one_space; @+break;
      case '[': *b++=match_left_side; @+break;
      case ']': *b++=match_right_side; @+break;
      default: *b++=*p; @+break;
    }
  }
  *b=0;
}

@ @<Add the pattern marker if applicable@>= {
  if(buf[1]>' ') *b++=buf[1]|0x80;
}

@ @<Add a keyword category to this pattern@>= {
  pattern_areas.data[cur_data].category=find_category(buf+1);
}

@ @<Append contents of |add_buf| to the pattern...@>= {
  if(*add_buf) {
    int z=strlen(pat->text);
    pat->text=realloc(pat->text,z+strlen(add_buf)+1);
    strcpy(pat->text+z,add_buf);
  }
}

@*Subroutine State. This state is used to add a named subroutine.

@<Process subroutine heading@>= {
  cur_name=find_name(buf)-256;
  if(!names.data[cur_name].value.is_string) {
    names.data[cur_name].value.is_string=1;
    names.data[cur_name].value.text=strdup("");
  }
}

@ @<Process subroutine state@>= {
  int z=strlen(names.data[cur_name].value.text);
  names.data[cur_name].value.text=realloc(names.data[cur_name].value.text,
    z+strlen(buf)+1);
  strcpy(names.data[cur_name].value.text+z,buf);
}

@*Word Forms State. You can use the word forms state to enter rules and
exceptions for word forms, such as plurals.

@<Global variables@>=
char wordform_code[256]; // code to execute at \.= line
char wordform_kind; // which kind of word forms is being made now?

@ @<Process word forms state@>= {
  switch(*buf) {
    case '>': @<Process \.> line in word forms state@>; @+break;
    case '=': @<Process \.= line in word forms state@>; @+break;
    case '#': wordform_kind=buf[1]; @+break;
    default: if(*buf>='0' && *buf<='9')
      @<Process numeric line in word forms state@>;
  }
}

@ The commands are \.>, \.=, and numbers. The command \.> sets a code for
processing \.= commands, and then add to the list.

@<Process \.> line in word forms state@>= {
  strcpy(wordform_code,buf+1);
}

@ @<Process \.= line in word forms state@>= {
  int level,kind;
  char*orig;
  char*dest;
  push_string(buf+1);
  execute_program(wordform_code);
  kind=pop_num(); @+ level=pop_num();
  dest=pop_string(); @+ orig=pop_string();
  add_word_form(kind,level,orig,dest);
  free(orig); @+ free(dest);
}

@ Now the command for numeric forms. You put ``level\.:orig\.:dest'' in
that order, please.

@<Process numeric line in word forms state@>= {
  int level=strtol(buf,&buf,0);
  char*p;
  if(*buf==':') buf++;
  p=strchr(buf,':');
  if(p) *p=0;
  add_word_form(wordform_kind,level,buf,p+1);
}

@*Writing Output Files. Finally, it will be time to send any output
generated into the files (if there is any, which there usually is).

@^output@>

@d ctrl(_letter) (0x1F&(_letter))
@#
@d call_final_subroutine ctrl('C')
@d copy_field ctrl('F')
@d newline ctrl('J')
@d loop_point ctrl('L')
@d next_record ctrl('N')
@d skip_one_character ctrl('S')

@<Write the output files@>= {
  data_index n;
  foreach(n,names) {
    if(names.data[n].is_output_file && names.data[n].value.is_string)
      @<Write this output file@>;
  }
}

@ @<Write this output file@>= {
  FILE*fout=fopen(names.data[n].name,"w");
  char*ptr=names.data[n].value.text;
  char*loopptr=ptr; // loop point
  if(!fout) @<Error about unable to open output file@>;
  while(*ptr) @<Write the character and advance to the next one@>;
  fclose(fout);
}

@ @<Error about unable to open output file@>= {
  fprintf(stderr,"Unable to open output file: %s\n",names.data[n].name);
@.Unable to open output file@>
  exit(1);
}

@ @<Write the character and advance to the next one@>= {
  switch(*ptr) {
    case call_final_subroutine: @<Do |call_final_subroutine|@>; @+break;
    case copy_field: @<Do |copy_field|@>; @+break;
    case loop_point: loopptr=++ptr; @+break;
    case next_record: @<Do |next_record|@>; @+break;
    case skip_one_character: ptr+=2; @+break;
    default: fputc(*ptr++,fout);
  }
  done_writing_one_character: ;
}

@ @<Do |call_final_subroutine|@>= {
  register_value*v;
  if(*++ptr=='(') {
    char*p=strchr(ptr,')');
    *p=0;
    v=&name_info(find_name(ptr+1)).value;
    *p=')';
    ptr=p+1;
  } @+else {
    v=&registers[*ptr++];
  }
  if(v->is_string) {
    execute_program(v->text);
    @<Write or loop based on result of subroutine call@>;
    stack_drop();
  }
}

@ @<Write or loop based on result of subroutine call@>= {
  if(stack_ptr->is_string) {
    fprintf(fout,"%s",stack_ptr->text);
  } @+else if(stack_ptr->number) {
    ptr=loopptr;
  }
}

@ This command is used to copy the next field.

Look at the definition for the |send_reg_char_or_text| macro. It is
strange, but it should work wherever a statement is expected. Please note
that a ternary condition operator should have both choices of the same
type.

@^strange codes@>

@d tok_idx (registers['A'].number)
@d tok_area
  (card_areas.data[name_info(registers['C'].number).value.number].tokens)

@d send_reg_char_or_text(_reg)
  if(!registers[_reg].is_string || *registers[_reg].text)
    fprintf(fout, "%c%s",
      registers[_reg].is_string?
        *registers[_reg].text:registers[_reg].number,
      registers[_reg].is_string?
        registers[_reg].text+1:(unsigned char*)""
    )@;

@<Do |copy_field|@>= {
  ++ptr;
  for(;;) {
    switch(tok_area[tok_idx++]) {
      case null_char: @<Unexpected |null_char|@>;
      case end_transmission: tok_idx=0; @+goto done_writing_one_character;
      case tabulation: send_reg_char_or_text('T'); @+break;
      case raw_data: @<Do |raw_data|@>; @+break;
      case escape_code: send_reg_char_or_text('E'); @+break;
      case record_separator: tok_idx--; @+goto done_writing_one_character;
      case field_separator: @+goto done_writing_one_character;
      default: @/
        if(tok_area[--tok_idx]&~0xFF)
          @<Deal with name code@>@;
        else
          @<Deal with normal character@>;
        tok_idx++;
    }
  }
}

@ @<Unexpected |null_char|@>= {
  fprintf(stderr,"Unexpected null character found in a card area\n");
@.Unexpected null character...@>
  exit(1);
}

@ @<Do |raw_data|@>= {
  while(tok_area[tok_idx]) fputc(tok_area[tok_idx++],fout);
  tok_idx++;
}

@ A name code found here is a code to tell it to call the subroutine code
when it is time to write it out to the file. It should return a string on
the stack (if it is a number, it will be ignored).

@<Deal with name code@>= {
  if(name_info(tok_area[tok_idx]).value.is_string)
    execute_program(name_info(tok_area[tok_idx]).value.text);
  if(stack_ptr->is_string) fprintf(fout,"%s",stack_ptr->text);
  stack_drop();
}

@ In case of a normal character, normally just write it out. But some
characters need escaped for \TeX.

@<Deal with normal character@>= {
  if(tables['E'][tok_area[tok_idx]]) send_reg_char_or_text('E');
  fputc(tok_area[tok_idx],fout);
}

@ This one moves to the next record, looping if a next record is in fact
available. Otherwise, just continue. Note that a |record_separator|
immediately followed by a |end_transmission| is assumed to mean there is
no next record, and that there is allowed to be a optional
|record_separator| just before the |end_transmission|.

@<Do |next_record|@>= {
  ++ptr;
  while(tok_area[tok_idx]!=record_separator &&
   tok_area[tok_idx]!=end_transmission) tok_idx++;
  if(tok_area[tok_idx]!=end_transmission &&
   tok_area[tok_idx+1]!=end_transmission) ptr=loopptr;
}

@*Functions Common to DVI and GF. Numbers for \.{GF} and \.{DVI} files use
the |dvi_number| data type. (Change this in the change file if the current
setting is inappropriate for your system.)

There is also the |dvi_measure| type, which is twice as long and is used
to compute numbers that can be fractional (with thirty-two fractional bits
and thirty-two normal bits).

@<Typedefs@>=
@q[Type of DVI numbers::]@>
typedef signed int dvi_number;
typedef signed long long int dvi_measure;
@q[::Type of DVI numbers]@>

@ There is one subroutine here to read a |dvi_number| from a file. They
come in different sizes and some are signed and some are unsigned.

@^endianness@>
@^byte order@>

@-p dvi_number get_dvi_number(FILE*fp,boolean is_signed,int size) {
  dvi_number r=0;
  if(size) r=fgetc(fp);
  if((r&0x80) && is_signed) r|=0xFFFFFF00;
  while(--size) r=(r<<8)|fgetc(fp);
  return r;
}

@ Some macros are defined here in order to deal with |dvi_measure| values.

@^fractions@>

@d to_measure(_value) (((dvi_measure)(_value))<<32)
@d floor(_value) ((dvi_number)((_value)>>32))
@d round(_value) ((dvi_number)(((_value)+0x8000)>>32))
@d ceiling(_value) ((dvi_number)(((_value)+0xFFFF)>>32))

@ Here division must be done in a careful way, to ensure that none of the
intermediate results exceed sixty-four bits.

@d fraction_one to_measure(1)

@-p dvi_measure make_fraction(dvi_measure p,dvi_measure q) {
  dvi_measure f,n;
  boolean negative=(p<0)^(q<0);
  if(p<0) p=-p;
  if(q<0) q=-q;
  n=p/q; @+ p=p%q;
  n=(n-1)*fraction_one;
  @<Compute $f=\lfloor2^{32}(1+p/q)+{1\over2}\rfloor$@>;
  return (f+n)*(negative?-1:1);
}

@ Notice that the computation specifies $(p-q)+p$ instead of $(p+p)-q$,
because the latter could overflow.

@<Compute $f=...@>= {
  register dvi_measure b;
  f=1;
  while(f<fraction_one) {
    b=p-q; @+ p+=b;
    if(p>=0) {
      f+=f+1;
    } @+else {
      f<<=1;
      p+=q;
    }
  }
}

@ And a few miscellaneous macros.

@d upto4(_var,_cmd) (_var>=_cmd && _var<_cmd+4)

@*DVI Reading. The device-independent file format is a format invented by
David R.~Fuchs in 1979. The file format need not be explained here, since
there are other books which explain it\biblio{Knuth, Donald. ``\TeX: The
Program''. Computers {\char`\&} Typesetting. ISBN 0-201-13437-3.}\biblio{%
Knuth, Donald. ``\TeX ware''. Stanford Computer Science Report 1097.}.

\edef\TeXwareBiblio{\the\bibliocount}
@^Fuchs, David@>
@.DVI@>
@^device independent@>

At first, names will be given for the commands in a \.{DVI} file.

@d set_char_0 0 // Set a character and move [up to 127]
@d set1 128 // Take one parameter to set character [up to 131]
@d set_rule 132 // Set a rule and move down, two parameters
@d put1 133 // As |set1| but no move [up to 136]
@d put_rule 137 // As |set_rule| but no move
@d nop 138 // No operation
@d bop 139 // Beginning of a page
@d eop 140 // End of a page
@d push 141 // Push $(h,v,w,x,y,z)$ to the stack
@d pop 142 // Pop $(h,v,w,x,y,z)$ from the stack
@d right1 143 // Take one parameter, move right [up to 146]
@d w0 147 // Move right $w$ units
@d w1 148 // Set $w$ and move right [up to 151]
@d x0 152 // Move right $x$ units
@d x1 153 // Set $x$ and move right [up to 156]
@d down1 157 // Take one parameter, move down [up to 160]
@d y0 161 // Move down $y$ units
@d y1 162 // Set $y$ and move down [up to 165]
@d z0 166 // Move down $z$ units
@d z1 167 // Set $z$ and move down [up to 170]
@d fnt_num_0 171 // Select font 0 [up to 234]
@d fnt1 235 // Take parameter to select font [up to 238]
@d xxx1 239 // Specials [up to 242]
@d fnt_def1 243 // Font definitions [up to 246]
@d pre 247 // Preamble
@d post 248 // Postamble
@d post_post 249 // Postpostamble

@ We should now start reading the \.{DVI} file. Filenames of fonts being
used will be sent to standard output.

@-p boolean read_dvi_file(char*filename) {
  boolean fonts_okay=1;
  FILE*fp=fopen(filename,"rb");
  if(!fp) dvi_error(fp,"Unable to open file");
  @#@<Skip the preamble of the \.{DVI} file@>;
  @<Skip to the next page@>;
  @<Read the metapage heading@>;
  @<Compute the conversion factor@>;
  read_dvi_page(fp);
  @<Skip to and read the postamble@>;
  @<Read the font definitions and load the fonts@>;
  if(fonts_okay) @<Read the pages for each card@>;
  @#fclose(fp);
  return fonts_okay;
}

@ @-p void dvi_error(FILE*fp,char*text) {
  fprintf(stderr,"DVI error");
@.DVI error@>
  if(fp) fprintf(stderr," at %08X",ftell(fp));
  fprintf(stderr,": %s\n",text);
  exit(1);
}

@ Please note the version number of the \.{DVI} file must be 2.

@<Skip the preamble of the \.{DVI} file@>= {
  if(fgetc(fp)!=pre) dvi_error(fp,"Bad preamble");
  if(fgetc(fp)!=2) dvi_error(fp,"Wrong DVI version");
  @<Read the measurement parameters@>;
  @<Skip the DVI comment@>;
}

@ @<Read the measurement parameters@>= {
  unit_num=get_dvi_number(fp,0,4);
  unit_den=get_dvi_number(fp,0,4);
  unit_mag=get_dvi_number(fp,0,4);
}

@ @<Skip the DVI comment@>= {
  int n=fgetc(fp);
  fseek(fp,n,SEEK_CUR);
}

@ From the postamble we can read the pointer for the last page.

@<Global variables@>=
dvi_number last_page_ptr;

@ @<Skip to and read the postamble@>= {
  fseek(fp,-4,SEEK_END);
  while(fgetc(fp)==223) fseek(fp,-2,SEEK_CUR);
  fseek(fp,-5,SEEK_CUR);
  fseek(fp,get_dvi_number(fp,0,4)+1,SEEK_SET);
  last_page_ptr=get_dvi_number(fp,0,4);
  fseek(fp,20,SEEK_CUR); // Skipped parameters of |post|
  dvi_stack=malloc(get_dvi_number(fp,0,2)*sizeof(dvi_stack_entry));
  fseek(fp,2,SEEK_CUR);
}

@ Between the preamble and the first page can be |nop| commands and font
definitions, so these will be skipped. The same things can occur between
the end of one page and the beginning of the next page.

@<Skip to the next page@>= {
  int c;
  for(;;) {
    c=fgetc(fp);
    if(c==bop) break;
    if(c>=fnt_def1 && c<fnt_def1+4) {
      @<Skip a font definition@>;
    } @+else if(c!=nop) {
      dvi_error(fp,"Bad command between pages");
    }
  }
}

@ @<Skip a font definition@>= {
  int a,l;
  fseek(fp,c+13-fnt_def1,SEEK_CUR);
  a=fgetc(fp);
  l=fgetc(fp);
  fseek(fp,a+l,SEEK_CUR);
}

@ The metapage includes the resolution and other things which must be set,
such as subroutine codes. The resolution must be read before fonts can be
read. Please note that no characters can be typeset on the metapage, since
fonts have not been loaded yet. You can still place empty boxes. The DPI
setting (resolution) is read from the \.{\\count1} register.

@<Read the metapage heading@>= {
  dvi_number n=get_dvi_number(fp,0,4);
  if(n) {
    fprintf(stderr,"Metapage must be numbered zero (found %d).\n",n);
@.Metapage must be...@>
    exit(1);
  }
  push_num(get_dvi_number(fp,0,4)); @+ store('D');
  fseek(fp,9*4,SEEK_CUR); // Skip other parameters
  layer_width=layer_height=0;
}

@ A stack is kept of the page registers, for use with the |push| and |pop|
commands of a \.{DVI} file. This stack is used by the |read_dvi_page|
subroutine and stores the |quan| registers (described in the next
chapter).

@<Typedefs@>=
typedef struct {
  dvi_number h;
  dvi_number v;
  dvi_number w;
  dvi_number x;
  dvi_number y;
  dvi_number z;
  dvi_number hh;
  dvi_number vv;
} dvi_stack_entry;

@ @<Global variables@>=
dvi_stack_entry*dvi_stack;
dvi_stack_entry*dvi_stack_ptr;

@ Here is the subroutine to read commands from a DVI page. The file
position should be at the beginning of the page after the |bop| command.

@^pages@>

@-p void read_dvi_page(FILE*fp) {
  memusage_log("Beginning of page",fseek(fp));
  @<Reset the page registers and stack@>;
  typeset_new_page();
  @<Read the commands of this page@>;
  if(layer_width && layer_height) @<Render this page@>;
}

@ @<Reset the page registers and stack@>= {
  quan('A')=quan('B')=quan('H')=quan('I')=quan('J')=quan('L')=quan('V')=
  quan('W')=quan('X')=quan('Y')=quan('Z')=0;
  dvi_stack_ptr=dvi_stack;
}

@ @<Read the commands of this page@>= {
  int c,a;
  boolean moveaftertyping;
  for(;;) {
    c=fgetc(fp);
    if(c<set1) {
      moveaftertyping=1;
      @<Typeset character |c| on the current layer@>;
    } @+else if(upto4(c,set1)) {
      moveaftertyping=1;
      c=get_dvi_number(fp,0,c+1-set1);
      @<Typeset character |c| on the current layer@>;
    } @+else if(c==set_rule || c==put_rule) {
      moveaftertyping=(c==set_rule);
      c=get_dvi_number(fp,1,4);
      a=get_dvi_number(fp,1,4);
      @<Typeset |a| by |c| rule on the current layer@>;
    } @+else if(upto4(c,put1)) {
      moveaftertyping=0;
      c=get_dvi_number(fp,0,c+1-put1);
      @<Typeset character |c| on the current layer@>;
    } @+else if(c==eop) {
      break;
    } @+else if(c==push) {
      if(dvi_stack) @<Push DVI registers to stack@>;
    } @+else if(c==pop) {
      if(dvi_stack) @<Pop DVI registers from stack@>;
    } @+else if(upto4(c,right1)) {
      c=get_dvi_number(fp,1,c+1-right1);
      horizontal_movement(c);
    } @+else if(c==w0) {
      horizontal_movement(quan('W'));
    } @+else if(upto4(c,w1)) {
      c=get_dvi_number(fp,1,c+1-w1);
      horizontal_movement(quan('W')=c);
    } @+else if(c==x0) {
      horizontal_movement(quan('X'));
    } @+else if(upto4(c,x1)) {
      c=get_dvi_number(fp,1,c+1-x1);
      horizontal_movement(quan('X')=c);
    } @+else if(upto4(c,down1)) {
      c=get_dvi_number(fp,1,c+1-down1);
      vertical_movement(c);
    } @+else if(c==y0) {
      vertical_movement(quan('Y'));
    } @+else if(upto4(c,y1)) {
      c=get_dvi_number(fp,1,c+1-y1);
      vertical_movement(quan('Y')=c);
    } @+else if(c==z0) {
      vertical_movement(quan('Z'));
    } @+else if(upto4(c,z1)) {
      c=get_dvi_number(fp,1,c+1-z1);
      vertical_movement(quan('Z')=c);
    } @+else if(c>=fnt_num_0 && c<fnt1) {
      quan('F')=c-fnt_num_0;
    } @+else if(upto4(c,fnt1)) {
      quan('F')=get_dvi_number(fp,0,c+1-fnt1);
    } @+else if(upto4(c,xxx1)) {
      c=get_dvi_number(fp,0,c+1-xxx1);
      @<Read a special of length |c|@>;
    } @+else if(upto4(c,fnt_def1)) {
      @<Skip a font definition@>;
    } @+else if(c!=nop) {
      dvi_error(fp,"Unknown DVI command");
    }
  }
}

@ @<Push DVI registers to stack@>= {
  dvi_stack_ptr->h=quan('H');
  dvi_stack_ptr->v=quan('V');
  dvi_stack_ptr->w=quan('W');
  dvi_stack_ptr->x=quan('X');
  dvi_stack_ptr->y=quan('Y');
  dvi_stack_ptr->z=quan('Z');
  dvi_stack_ptr->hh=quan('I');
  dvi_stack_ptr->vv=quan('J');
  ++dvi_stack_ptr;
}

@ @<Pop DVI registers from stack@>= {
  --dvi_stack_ptr;
  quan('H')=dvi_stack_ptr->h;
  quan('V')=dvi_stack_ptr->v;
  quan('W')=dvi_stack_ptr->w;
  quan('X')=dvi_stack_ptr->x;
  quan('Y')=dvi_stack_ptr->y;
  quan('Z')=dvi_stack_ptr->z;
  quan('I')=dvi_stack_ptr->hh;
  quan('J')=dvi_stack_ptr->vv;
}

@ A special in \TeX nicard is used to execute a special code while reading
the DVI file. Uses might be additional calculations, changes of registers,
special effects, layer selection, etc. All of these possible commands are
dealt with elsewhere in this program. All we do here is to read it and to
send it to the |execute_program| subroutine.

@^specials@>

@<Read a special of length |c|@>= {
  char*buf=malloc(c+1);
  fread(buf,1,c,fp);
  buf[c]=0;
  @<Set \.X and \.Y registers to prepare for the special@>;
  execute_program(buf);
  free(buf);
}

@ @<Set \.X and \.Y registers to prepare for the special@>= {
  registers['X'].is_string=registers['Y'].is_string=0;
  registers['X'].number=quan('I');
  registers['Y'].number=quan('J');
}

@ In order to read all the pages for each card, we can skip backwards by
using the back pointers. Either we will print all cards (in reverse
order), or we will print cards listed on the command-line, or we will
print cards listed in a file (this last way might be used to print decks
or booster packs).

Card numbers should be one-based, and should not be negative. Any pages
with negative page numbers will be ignored when it is in the mode for
printing all cards.

@d printing_all_cards 0
@d printing_list 1
@d printing_list_from_file 2

@<Global variables@>=
unsigned char printing_mode;
char*printlisttext;
FILE*printlistfile;

@ @<Read the pages for each card@>= {
  dvi_number page_ptr=last_page_ptr;
  dvi_number e=0,n; // page numbers
  boolean pagenotfound=0;
  for(;;) {
    @<Read the next entry from the list of pages (if applicable)@>;
    try_next_page:
    @<Seek the next page to print@>;
    @<Read the heading for this page@>;
    @<If this page shouldn't be printed now, |goto try_next_page|@>;
    pagenotfound=0;
    read_dvi_page(fp);
  }
  @#done_printing:;
}

@ @<Read the next entry from the list of pages (if applicable)@>= {
  if(printing_mode==printing_list) {
    if(!*printlisttext) goto done_printing;
    e=strtol(printlisttext,&printlisttext,10);
    if(!e) goto done_printing;
    if(*printlisttext) printlisttext++;
  } @+else if(printing_mode==printing_list_from_file) {
    char buf[256];
    if(!printlistfile || feof(printlistfile)) goto done_printing;
    if(!fgets(buf,255,printlistfile)) goto done_printing;
    e=strtol(buf,0,10);
  }
}

@ @<Seek the next page to print@>= {
  if(page_ptr==-1) {
    if(pagenotfound) {
      fprintf(stderr,"No page found: %d\n",e);
@.No page found...@>
      exit(1);
    }
    page_ptr=last_page_ptr;
    if(printing_mode==printing_all_cards) goto done_printing;
    pagenotfound=1;
  }
  fseek(fp,page_ptr+1,SEEK_SET);
}

@ @<Read the heading for this page@>= {
  n=quan('P')=get_dvi_number(fp,1,4);
  fseek(fp,4,SEEK_CUR);
  layer_width=get_dvi_number(fp,1,4);
  layer_height=get_dvi_number(fp,1,4);
  fseek(fp,4*6,SEEK_CUR);
  page_ptr=get_dvi_number(fp,1,4);
}

@ @<If this page shouldn't be printed now, |goto try_next_page|@>= {
  if(n<=0 && printing_mode==printing_all_cards) goto try_next_page;
  if(n!=e && printing_mode!=printing_all_cards) goto try_next_page;
}

@*DVI Font Metrics. Here, the fonts are loaded. It is assumed all fonts
are in the current directory, and the ``area'' of the font name is
ignored. The checksum will also be ignored (it can be checked with
external programs if necessary).

@^area@>
@^font loading@>

@<Read the font definitions and load the fonts@>= {
  int c;
  for(;;) {
    c=fgetc(fp);
    if(c==post_post) break;
    if(c>=fnt_def1 && c<fnt_def1+4) {
      int k=get_dvi_number(fp,0,c+1-fnt_def1);
      if(k&~0xFF) dvi_error(fp,"Too many fonts");
      memusage_log("Loading font",k);
      @<Read the definition for font |k| and load it@>;
    } @+else if(c!=nop) {
      dvi_error(fp,"Bad command in postamble");
    }
  }
  memusage_log("End of postamble",c);
}

@ When reading fonts, it will be necessary to keep a list of the fonts
and their character indices. Only 256 fonts are permitted in one job.

@<Global variables@>=
data_index fontindex[256];

@ @<Read the definition for font |k| and load it@>= {
  dvi_number c=get_dvi_number(fp,0,4); // checksum (unused)
  dvi_number s=get_dvi_number(fp,0,4); // scale factor
  dvi_number d=get_dvi_number(fp,0,4); // design size
  int a=get_dvi_number(fp,0,1); // length of area
  int l=get_dvi_number(fp,0,1); // length of name
  char n[257];
  fseek(fp,a,SEEK_CUR);
  fread(n,1,l,fp);
  n[l]=0;
  if((fontindex[k]=read_gf_file(n,s,d))==none) fonts_okay=0;
}

@ An important part of reading the font metrics is the width computation,
which involves multiplying the relative widths in the \.{TFM} file (or
\.{GF} file) by the scaling factor in the \.{DVI} file. This
multiplication must be done in precisely the same way by all \.{DVI}
reading programs, in order to validate the assumptions made by \.{DVI}-%
writing programs such as \TeX.

% (The following paragraph is taken directly from "dvitype.web")
Let us therefore summarize what needs to be done. Each width in a \.{TFM}
file appears as a four-byte quantity called a |fix_word|.  A |fix_word|
whose respective bytes are $(a,b,c,d)$ represents the number
$$x=\left\{\vcenter{\halign{$#$,\hfil\qquad&if $#$\hfil\cr
b\cdot2^{-4}+c\cdot2^{-12}+d\cdot2^{-20}&a=0;\cr
-16+b\cdot2^{-4}+c\cdot2^{-12}+d\cdot2^{-20}&a=255.\cr}}\right.$$
(No other choices of $a$ are allowed, since the magnitude of a \.{TFM}
dimension must be less than 16.)  We want to multiply this quantity by the
integer~|z|, which is known to be less than $2^{27}$.
If $|z|<2^{23}$, the individual multiplications $b\cdot z$, $c\cdot z$,
$d\cdot z$ cannot overflow; otherwise we will divide |z| by 2, 4, 8, or
16, to obtain a multiplier less than $2^{23}$, and we can compensate for
this later. If |z| has thereby been replaced by $|z|^\prime=|z|/2^e$, let
$\beta=2^{4-e}$; we shall compute
$$\lfloor(b+c\cdot2^{-8}+d\cdot2^{-16})\,z^\prime/\beta\rfloor$$ if $a=0$,
or the same quantity minus $\alpha=2^{4+e}z^\prime$ if $a=255$.
This calculation must be
done exactly, for the reasons stated above; the following program does the
job in a system-independent way, assuming that arithmetic is exact on
numbers less than $2^{31}$ in magnitude.

\def\zprime{z'}

@f alpha TeX
@f beta TeX
@f zprime TeX

@<Compute |zprime|, |alpha|, and |beta|@>= {
  zprime=s; @+ alpha=16;
  while(zprime>=040000000) {
    zprime>>=1; @+ alpha<<=1;
  }
  beta=256/alpha; @+ alpha*=zprime;
}

@ @<Compute the character width |w|@>= {
  w=(((((b3*zprime)>>8)+(b2*zprime))>>8)+(b1*zprime))/beta;
  if(b0) w-=alpha;
}

@*GF Reading. The \.{GF} format is a ``generic font'' format. It has a lot
in common with \.{DVI} format.

At first, names will be given for the commands in a \.{GF} file. Many
commands have the same numbers as they do in a \.{DVI} file (described in
the previous chapter), which makes it very convenient\biblio{This is
probably on purpose for the this very reason, so that a WEB or CWEB
program can use one set of named constants for reading both files.}.

@d paint_0 0 // Paint $d$ pixels black or white [up to 63]
@d paint1 64 // Take parameter, paint pixels [up to 66]
@d boc 67 // Beginning of a character picture
@d boc1 68 // Short form of |boc|
@d eoc 69 // End of a character picture
@d skip0 70 // Skip some rows
@d skip1 71 // Skip some rows [up to 73]
@d new_row_0 74 // Start a new row and move right [up to 238]
@d yyy 243 // Numeric specials
@d no_op 244 // No operation
@d char_loc 245 // Character locator
@d char_loc0 246 // Short form of |char_loc|

@ The |font_struct| structure stores the information for each character in
a font. The |raster| field points to a bitmap with eight pixels per octet,
most significant bit for the leftmost pixel, each row always padded to a
multiple of eight pixels.

While it is reading the postamble, it will fill in this structure with the
|ptr| field set. After the postamble is read, it will fill in the other
fields belonging to its union.

@<Typedefs@>=
typedef struct {
  dvi_number dx; // character escapement in pixels
  dvi_number w; // width in DVI units
  union {
    struct {
      dvi_number min_n,max_n,min_m,max_m; // bounding box (in pixels)
      unsigned short n; // character code number
      unsigned char*raster;
      unsigned char flag; // bitfield of flags for this character
    }@+;
    dvi_number ptr;
  }@+;
  data_index next;
} font_struct;

@ List of flags follows. Some of these flags might be used in order to
allow$\mathord{}>256$ characters per font, since {\TeX} does not have a
command to enter characters with codes more than one byte long. These
flags are specified using numeric specials.

@d ff_select 0x01 // set high octet all characters
@d ff_prefix 0x02 // set high octet for codes 128-255
@d ff_roundafter 0x04 // round $\it hh$ after sending character
@d ff_roundbefore 0x08 // round $\it hh$ before sending character
@d ff_reset 0x10 // reset high octet
@d ff_strip 0x20 // strip highest bit of prefix
@d ff_space 0x40 // do not save the raster (space only)
@d ff_reserved 0x80 // {\bf DO NOT USE}

@ @<Global variables@>=
memory_of(font_struct) font_data;

@ @<Initialize memory@>= init_memory(font_data,4);

@ When loading a \.{GF} font, the filename will contain the resolution
in dots per inch.

@^font loading@>

@-p data_index read_gf_file(char*fontname,dvi_measure s,dvi_measure d) {
  unsigned int dpi=(resolution*unit_mag*s+500*d)/(100000*d);
  FILE*fp;
  data_index index=none;
  data_index first_index=none;
  data_index last_index=none;
  dvi_number zprime,alpha,beta; // used for width computation
  @<Compute |zprime|, |alpha|, and |beta|@>;
 @<Figure out the filename and open the file, |return none| if it can't@>;
  @<Skip to the postamble of the \.{GF} file@>;
  @<Read the character locators@>;
  @<Read the character rasters and flags@>;
  fclose(fp);
  return last_index;
}

@ When figuring out the filename, it will send it to standard output so
that a list can be made of the required fonts.

@<Figure out the filename and open the file, ...@>= {
  char n[295];
  sprintf(n,"%s.%dgf",fontname,dpi);
  printf("%s\n",n);
  fp=open_file(n,"rb");
  if(!fp) return none;
}

@ @<Skip to the postamble of the \.{GF} file@>= {
  int c;
  fseek(fp,-4,SEEK_END);
  while(fgetc(fp)==223) fseek(fp,-2,SEEK_CUR);
  fseek(fp,-5,SEEK_CUR);
  fseek(fp,get_dvi_number(fp,0,4)+37,SEEK_SET); // nothing matters anymore
}

@ @<Read the character locators@>= {
  int c,b0,b1,b2,b3;
  dvi_number dx,w,p;
  for(;;) {
    c=fgetc(fp);
    if(c==post_post) break;
    p=-1;
    if(c==char_loc) {
      @<Read a long character locator@>;
    } @+else if(c==char_loc0) {
      @<Read a short character locator@>;
    } @+else if(c!=no_op) {
      fprintf(stderr,"Bad command in GF postamble.\n");
@.Bad command in GF postamble@>
      fprintf(stderr,"(Command %d, address %08X)\n",c,ftell(fp)-1);
      exit(1);
    }
    if(p!=-1) @<Defer this character locator into |font_data|@>;
  }
  last_index=index;
}

@ There are some parameters we do not care about. First is $c$, which is
the character code residue (modulo 256). This is not important since it
is duplicated in the |boc| heading for each character. The second
parameter which we do not care about is the $\it dy$ parameter, since it
should be zero for \.{DVI} files.

@<Read a long character locator@>= {
  fseek(fp,1,SEEK_CUR);
  dx=get_dvi_number(fp,1,4)>>16;
  fseek(fp,4,SEEK_CUR);
  @<Read four bytes@>;
  p=get_dvi_number(fp,1,4);
}

@ @<Read a short character locator@>= {
  fseek(fp,1,SEEK_CUR);
  dx=get_dvi_number(fp,0,1);
  @<Read four bytes@>;
  p=get_dvi_number(fp,1,4);
}

@ @<Read four bytes@>= {
  b0=fgetc(fp);@+b1=fgetc(fp);@+b2=fgetc(fp);@+b3=fgetc(fp);
}

@ This processing is deferred, and the rest of the parameters will be
filled in later (and the |ptr| field will be overwritten since it will
no longer be needed at that time).

@<Defer this character locator into |font_data|@>= {
  data_index n=new_record(font_data);
  @<Compute the character width |w|@>;
  font_data.data[n].next=index;
  font_data.data[n].dx=dx;
  font_data.data[n].w=w;
  font_data.data[n].ptr=p;
  if(index==none) first_index=n;
  index=n;
}

@ Now is time to go through the list we made up and this time actually
fill in the parameters and pictures.

@<Read the character rasters and flags@>= {
  while(index!=none) {
    fseek(fp,font_data.data[index].ptr,SEEK_SET);
    font_data.data[index].flag=0;
    font_data.data[index].raster=0;
    @<Read commands for this character@>;
    @#index=font_data.data[index].next;
  }
}

@ Painting the picture uses the value of |paint_switch| to determine
to draw or skip. The current position in the array |raster| is also
pointed by the |pic| pointer. Note that |black| and |white| are not
necessary black and white (but they are on normal paper).

Note the value of $n$ is not needed since the |pic| pointer automatically
keeps track of this kinds of stuff. However, |m| is needed because of
commands that can skip rows, to know how many columns must be skipped to
reach the next row. There is also |b|, which keeps track of the bit
position in the current byte.

@d white 0
@d black 1
@#
@d reset_m
  m=(font_data.data[index].max_m-font_data.data[index].min_m)/8+1@;

@<Read commands for this character@>= {
  unsigned int c,m,b;
  unsigned char*pic;
  boolean paint_switch;
  for(;;) {
    c=fgetc(fp);
    if(c<paint1) {
      @<Paint |c| pixels |black| or |white|@>;
    } @+else if(c>=paint1 && c<paint1+3) {
      c=get_dvi_number(fp,0,c+1-paint1);
      @<Paint |c| pixels |black| or |white|@>;
    } @+else if(c==boc) {
      @<Initialize parameters and picture (long form)@>;
    } @+else if(c==boc1) {
      @<Initialize parameters and picture (short form)@>;
    } @+else if(c==eoc) {
      break; // Well Done!
    } @+else if(upto4(c,skip0)) {
      if(c==skip0) c=0;
      else c=get_dvi_number(fp,0,c+1-skip1);
      @<Finish a row and skip |c| rows@>;
    } @+else if(c>=new_row_0 && c<=new_row_0+164) {
      c-=new_row_0;
      @<Finish a row and skip |c| columns@>;
    } @+else if(c==yyy) {
      font_data.data[index].flag|=get_dvi_number(fp,0,4)>>16;
    } @+else if(c!=no_op) {
      fprintf(stderr,"Unknown GF command!\n");
@.Unknown GF command@>
      fprintf(stderr,"(Command %d, address %08X)\n",c,ftell(fp)-1);
    }
  }
}

@ Actually |m| is something a bit different than the standard, because |m|
now tells how many bytes are remaining in the current row.

@d pic_rows (1+font_data.data[index].max_n-font_data.data[index].min_n)

@<Initialize parameters and picture (long form)@>= {
  font_data.data[index].n=get_dvi_number(fp,0,4);
  @<Deal with $p$ (pointer to previous character with same metrics)@>;
  font_data.data[index].min_m=get_dvi_number(fp,1,4);
  font_data.data[index].max_m=get_dvi_number(fp,1,4);
  font_data.data[index].min_n=get_dvi_number(fp,1,4);
  font_data.data[index].max_n=get_dvi_number(fp,1,4);
  @<Initialize picture@>;
}

@ @<Initialize picture@>= {
  if(font_data.data[index].flag&ff_space) break;
  paint_switch=white;
  reset_m;
  b=0;
  pic=font_data.data[index].raster=malloc(m*pic_rows+1);
  memset(pic,0,m*pic_rows);
}

@ @<Initialize parameters and picture (short form)@>= {
  int d;
  font_data.data[index].n=get_dvi_number(fp,0,1);
  d=get_dvi_number(fp,0,1);
  font_data.data[index].max_m=get_dvi_number(fp,0,1);
  font_data.data[index].min_m=font_data.data[index].max_m-d;
  d=get_dvi_number(fp,0,1);
  font_data.data[index].max_n=get_dvi_number(fp,0,1);
  font_data.data[index].min_n=font_data.data[index].max_n-d;
  @<Initialize picture@>;
}

@ The pointers to other characters will also be deferred in the same way
as the character locators, but this time from the other end. Now, once it
is finished all the characters, it will {\sl automatically} know to read
the next one properly! (Now you can see what the purpose of the
|@!first_index| variable is.)

@<Deal with $p$ (pointer to previous character with same metrics)@>= {
  dvi_number p=get_dvi_number(fp,1,4);
  if(p!=-1) {
    data_index i=new_record(font_data);
    font_data.data[i].next=none;
    font_data.data[i].dx=font_data.data[index].dx;
    font_data.data[i].w=font_data.data[index].w;
    font_data.data[i].ptr=p;
    font_data.data[first_index].next=i;
    first_index=i;
  }
}

@ Now we get to the actual painting. We can assume the value of |m| is
never negative and that everything else is also okay.

@<Paint |c| pixels |black| or |white|@>= {
  if(paint_switch) {
    if(b+c<=8) {
      @<Paint a small block of pixels in the current byte@>;
    } @+else {
      @<Paint the rest of the pixels in the current byte@>;
      @<Fill up the bytes in the middle@>;
      @<Clear the pixels needed clearing at the end@>;
    }
  }
  @<Update |paint_switch|, |pic|, |b|, and |m|@>;
}

@ @<Update |paint_switch|, |pic|, |b|, and |m|@>= {
  paint_switch^=1;
  b+=c;
  pic+=b>>3;
  m-=b>>3;
  b&=7;
}

@ @<Paint a small block of pixels in the current byte@>= {
  *pic|=(0xFF>>b)&~(0xFF>>(b+c));
}

@ @<Paint the rest of the pixels in the current byte@>= {
  *pic|=0xFF>>b;
}

@ @<Fill up the bytes in the middle@>= {
  memset(pic+1,0xFF,(c+b)>>3);
}

@ @<Clear the pixels needed clearing at the end@>= {
  pic[(c+b)>>3]&=~(0xFF>>((c+b)&7));
}

@ @<Finish a row and skip |c| rows@>= {
  pic+=m;
  b=0;
  reset_m;
  pic+=m*c;
  paint_switch=white;
}

@ @<Finish a row and skip |c| columns@>= {
  pic+=m;
  reset_m;
  m-=c>>3;
  pic+=c>>3;
  b=c&7;
  paint_switch=black;
}

@ @<Display font information@>= {
  data_index i;
  foreach(i,font_data) {
    printf("[%d] box=(%d,%d,%d,%d) dx=%d w=%d n=%d flag=%d [%d]\n"
      ,i,font_data.data[i].min_n,font_data.data[i].max_n
        ,font_data.data[i].min_m,font_data.data[i].max_m
      ,font_data.data[i].dx,font_data.data[i].w,font_data.data[i].n
      ,font_data.data[i].flag,font_data.data[i].next
    );
  }
}

@*Layer Computation. Now is the chapter for actually deciding rendering on
the page, where everything should go, etc.$^{[\TeXwareBiblio]}$

@<Global variables@>=
dvi_measure unit_num; // Numerator for units of measurement
dvi_measure unit_den; // Denominator for units of measurement
dvi_measure unit_mag; // Magnification for measurement
dvi_measure unit_conv; // Conversion factor

@ There are also a number of ``internal typesetting quantities''. These
are parameters stored in a separate array, and are used to keep track of
the current state of the typesetting. They are labeled with letters from
\.A to \.Z. They can be modified inside of specials, although some of them
probably shouldn't be modified in this way. Here is the list of them:

\.A, \.B: Horizontal and vertical offset added to \.I and \.J.

\.C: Character code prefix. If bit eight is not set, it only affects
character codes with bit seven set.

\.D: Maximum horizontal drift (in pixels), meaning how far away the \.I
and \.J parameters are allowed to be from the correctly rounded values.

\.E: Maximum vertical drift.

\.F: The current font.

\.H: The horizontal position on the page, in DVI units.

\.I: The horizontal position on the page, in pixels.

\.J: The vertical position on the page, in pixels.

\.L: The current layer number. If this is zero, nothing is placed on the
page, although the positions can still be changed and specials can still
be used.

\.P: Page number. This is used to determine the filename of output.

\.R, \.S: The limits for when horizontal motion should add the number of
pixels or when it should recalculate the pixels entirely.

\.T, \.U: Like \.R and \.S, but for vertical motions.

\.V: The vertical position on the page, in DVI units.

\.W, \.X, \.Y, \.Z: The current spacing amounts, in DVI units.

@d quan(_name) (type_quan[(_name)&0x1F])

@<Global variables@>=
dvi_number type_quan[32];

@ @<Cases for system commands@>=
  @-case 'm': {
    // Modify an internal typesetting quantity
    if(stack_ptr->is_string) program_error("Type mismatch");
    quan(*++ptr)=pop_num();
    break;
  }@#

@ The conversion factor |unit_conv| is figured as follows: There are
exactly |unit_num/unit_den| decimicrons per DVI unit, and 254000
decimicrons per inch, and |resolution/100| pixels per inch. Then we have
to adjust this by the magnification |unit_mag|.

Division must be done slightly carefully to avoid overflow.

@d resolution (registers['D'].number)

@<Compute the conversion factor@>= {
  unit_conv=make_fraction(unit_num*resolution*unit_mag,unit_den*100000);
  unit_conv/=254000;
}

@ Here are the codes to compute movements. The definition of \.{DVI} files
refers to six registers which hold integer values in DVI units. However,
we also have two more registers, for horizontal and vertical pixel units.

A sequence of characters or rules might cause the pixel values to drift
from their correctly rounded values, since they are not usually an exact
integer number of pixels.

@d to_pixels(_val) round((_val)*unit_conv)

@-p void horizontal_movement(dvi_number x) {
  quan('H')+=x;
  if(x>quan('S') || x<quan('R')) {
    quan('I')=to_pixels(quan('H'));
  } @+else {
    quan('I')+=to_pixels(x);
    if(to_pixels(quan('H'))-quan('I')>quan('D'))
      quan('I')=to_pixels(quan('H'))+quan('D');
    if(to_pixels(quan('H'))-quan('I')<-quan('D'))
      quan('I')=to_pixels(quan('H'))-quan('D');
  }
}

@ @-p void vertical_movement(dvi_number x) {
  quan('V')+=x;
  if(x>quan('U') || x<quan('T')) {
    quan('J')=to_pixels(quan('V'));
  } @+else {
    quan('J')+=to_pixels(x);
    if(to_pixels(quan('V'))-quan('J')>quan('E'))
      quan('J')=to_pixels(quan('V'))+quan('E');
    if(to_pixels(quan('V'))-quan('J')<-quan('E'))
      quan('J')=to_pixels(quan('V'))-quan('E');
  }
}

@ This is now the part that does actual sending. When many characters
come next to each other, the rounding will be done such that the number
of pixels between two letters will always be the same whenever those two
letters occur next to each other.

@<Typeset character |c| on the current layer@>= {
  data_index n=fontindex[quan('F')&0xFF];
  if((quan('C')&0x100) || (c&0x80)) c|=quan('C')<<8;
  while(n!=none && c!=font_data.data[n].n)
    n=font_data.data[n].next;
  if(n==none) dvi_error(fp,"Character not in font");
  @<Typeset the character and update the current position@>;
  @<Update the character code prefix@>;
}

@ @<Typeset the character and update the current position@>= {
  if(font_data.data[n].flag&ff_roundbefore)
    quan('I')=to_pixels(quan('H'));
  if(quan('L') && font_data.data[n].raster) typeset_char_here(n);
  if(moveaftertyping) {
    quan('H')+=font_data.data[n].w;
    quan('I')+=font_data.data[n].dx;
    if(font_data.data[n].flag&ff_roundafter)
      quan('I')=to_pixels(quan('H'));
    else horizontal_movement(0);
  }
}

@ If you have a typesetting program that can ship out characters with
codes more than eight bits long, you won't need this. It is provided for
use with normal {\TeX} system.

@<Update the character code prefix@>= {
  if(font_data.data[n].flag&ff_strip) c&=0x7F; else c&=0xFF;
  if(font_data.data[n].flag&ff_select) quan('C')=c|0x100;
  if(font_data.data[n].flag&ff_prefix) quan('C')=c;
  if(font_data.data[n].flag&ff_reset) quan('C')=0;
}

@ The number of pixels in the height or width of a rule will always be
rounded up. However, unlike DVItype, this program has no floating point
rounding errors.

@d to_rule_pixels(_val) ceiling((_val)*unit_conv)

@<Typeset |a| by |c| rule on the current layer@>= {
  dvi_number x=to_rule_pixels(a);
  dvi_number y=to_rule_pixels(c);
  if(quan('L') && a>0 && c>0) typeset_rule_here(x,y);
  if(moveaftertyping) {
    quan('I')+=x;
    horizontal_movement(0);
  }
}

@ Sometimes you might want DVI units converted to pixels inside of a user
program contained in a DVI file. Here is how it is done.

@<Cases for system commands@>=
  @-case 'C': {
    // Convert DVI units to pixels
    if(stack_ptr->is_string) program_error("Type mismatch");
    stack_ptr->number=to_pixels(stack_ptr->number);
    break;
  }@#

@*Layer Rendering. Please note, these numbers are |short|, which means
that you cannot have more than 65536 pixels in width or in height. This
should not be a problem, because even if you have 3000 dots per inch, and
each card is 10 inches long, that is still only 30000 which is less than
half of the available width. (All units here are in pixels.)

In order to save memory, all typeset nodes are stored in one list at
first, and then rendered to a pixel buffer as each layer is being written
out to the \.{PBM} file, and then the buffer can be freed (or reset to
zero) afterwards to save memory.

@<Typedefs@>=
typedef struct {
  unsigned short x; // X position on page
  unsigned short y; // Y position on page
  union {
    struct {
      unsigned short w; // Width of rule
      unsigned short h; // Height of rule
    }@+;
    data_index c; // Character index in |font_data|
  }@+;
  unsigned char l; // Layer (high bit set for rules)
} typeset_node;

@ @<Global variables@>=
memory_of(typeset_node) typeset_nodes;

@ @<Initialize memory@>= init_memory(typeset_nodes,8);

@ We also have variables for the layer size (loaded from \.{\\count2}
and \.{\\count3} registers for the current page). If they are both zero,
then nothing will be rendered.

@<Global variables@>=
unsigned short layer_width;
unsigned short layer_height;

@ Here are the subroutines which typeset characters and rules onto the
page buffer. They are not rendered into a picture yet.

@d typeset_new_page() (typeset_nodes.used=0)
@d typeset_rule_here(_w,_h) typeset_rule(quan('I'),quan('J'),(_w),(_h));
@d typeset_char_here(_ch) typeset_char(quan('I'),quan('J'),(_ch));

@-p void typeset_rule(int x,int y,int w,int h) {
  data_index n=new_record(typeset_nodes);
  @<Ensure |w| and |h| are not too large to fit on the page@>;
  typeset_nodes.data[n].x=x;
  typeset_nodes.data[n].y=y;
  typeset_nodes.data[n].w=w;
  typeset_nodes.data[n].h=h;
  typeset_nodes.data[n].l=quan('L')|0x80;
}

@ @<Ensure |w| and |h| are not too large to fit on the page@>= {
  if(x+w>layer_width) w=layer_width-x;
  if(y+h>layer_height) h=layer_height-y;
}

@ @-p void typeset_char(int x,int y,data_index c) {
  data_index n=new_record(typeset_nodes);
  typeset_nodes.data[n].x=x;
  typeset_nodes.data[n].y=y;
  typeset_nodes.data[n].c=c;
  typeset_nodes.data[n].l=quan('L');
}

@ Here is a variable |image|. This is a pointer to the buffer for the
picture of the current layer, in \.{PBM} format. The internal quantity
\.L should be set now to the largest layer number in use, at the end of
the page, because it is used to determine how many layers must be sent to
the output.

@d image_max (image+layer_size)

@<Global variables@>=
unsigned char*image;

@ @<Render this page@>= {
  unsigned int row_size=((layer_width+7)>>3);
  unsigned int layer_size=row_size*layer_height;
  image=malloc(layer_size+1);
  while(quan('L')) {
    memset(image,0,layer_size);
    @<Read the |typeset_nodes| list and render any applicable nodes@>;
    @<Send the current layer to a file@>;
    --quan('L');
  }
  free(image);
}

@ @<Read the |typeset_nodes| list and render any applicable nodes@>= {
  data_index i;
  foreach(i,typeset_nodes) {
    if((typeset_nodes.data[i].l&0x7F)==quan('L')) {
      if(typeset_nodes.data[i].l&0x80) {
        @<Render a rule node@>;
      } @+else {
        @<Render a character node@>;
      }
    }
  }
}

@ In order to render a rule node (which is a filled |black| rectangle), it
is split into rows, and each row is split into three parts: the left end,
the filling, and the right end. However, if the width is sufficiently
small, it will fit in one byte and will not have to be split in this way.

There are also some checks to ensure that the entire rectangle will be
within the bounds of the image.

@<Render a rule node@>= {
  int y=1+typeset_nodes.data[i].y-typeset_nodes.data[i].h;
  int x=typeset_nodes.data[i].x;
  int w=typeset_nodes.data[i].w;
  if(y<0) y=0;
  if(typeset_nodes.data[i].y>=layer_height)
    typeset_nodes.data[i].y=layer_height-1;
  if((x&7)+w<=8) {
    @<Render a small rule node@>;
  } @+else {
    @<Render a large rule node@>;
  }
}

@ @<Render a small rule node@>= {
  for(;y<=typeset_nodes.data[i].y;y++) {
    image[y*row_size+(x>>3)]|=(0xFF>>(x&7))&~(0xFF>>((x&7)+w));
  }
}

@ @<Render a large rule node@>= {
  for(;y<=typeset_nodes.data[i].y;y++) {
    unsigned char*p=image+(y*row_size+(x>>3));
    *p++|=0xFF>>(x&7); // left
    memset(p,0xFF,((x&7)+w)>>3); // filling
    p[((x&7)+w)>>3]|=~(0xFF>>((x+w)&7)); // right
  }
}

@ Character nodes are a bit different. The pictures are already stored,
now we have to paste them into the layer picture. Since they will not
always be aligned to a multiple to eight columns (one byte), it will have
to shift out and shift in.

Again, it is necessary to ensure it doesn't go out of bounds. It has to be
a bit more careful for characters than it does for rules. Also note that
the \.{GF} format does not require that |min_m| and so on are the tightest
bounds possible.

@<Render a character node@>= {
  unsigned int ch=typeset_nodes.data[i].c;
  unsigned int x=typeset_nodes.data[i].x+font_data.data[ch].min_m;
  unsigned int y=typeset_nodes.data[i].y-font_data.data[ch].max_n;
  unsigned int z=typeset_nodes.data[i].y-font_data.data[ch].min_n;
  unsigned int w=(font_data.data[ch].max_m-font_data.data[ch].min_m)/8+1;
  register unsigned char sh=x&7; // shifting amount for right shift
  register unsigned char lsh=8-sh; // shifting amount for left shift
  unsigned char*p=image+(y*row_size+(x>>3));
  unsigned char*q=font_data.data[ch].raster;
  @<Cut off the part of character above the top of the layer image@>;
  while(y<=z && p+w<image_max) {
    @<Render the current row of the character raster@>;
    @<Advance to the next row of the character@>;
  }
}

@ @<Cut off the part of character above the top of the layer image@>= {
  if(y<0) {
    p-=row_size*y;
    q-=w*y;
    y=0;
  }
  if(p<image) p=image;
}

@ @<Render the current row of the character raster@>= {
  int j;
  for(j=0;j<w;j++) {
    p[j]|=q[j]>>sh;
    p[j+1]|=q[j]<<lsh;
  }
}

@ @<Advance to the next row of the character@>= {
  y++;
  q+=w;
  p+=row_size;
}

@ Layer files are output in \.{PBM} format, which is very similar to the
format which this program uses internally. ImageMagick is capable of
reading this format.

@.PBM@>
@^Portable Bitmap@>
@^ImageMagick@>
@^output@>

@<Send the current layer to a file@>= {
  FILE*fp;
  char filename[256];
  sprintf(filename,"P%dL%d.pbm",quan('P'),quan('L'));
  fp=fopen(filename,"wb");
  fprintf(fp,"P4%d %d ",layer_width,layer_height);
  fwrite(image,1,layer_size,fp);
  fclose(fp);
}

@ @<Display the list of typeset nodes@>= {
  data_index i;
  foreach(i,typeset_nodes) {
    if(typeset_nodes.data[i].l&0x80) {
      printf("[%d] %dx%d%+d%+d\n",typeset_nodes.data[i].l&0x7F
        ,typeset_nodes.data[i].w,typeset_nodes.data[i].h
        ,typeset_nodes.data[i].x,typeset_nodes.data[i].y
      );
    } @+else {
      printf("[%d] %d(%d) %+d%+d\n",typeset_nodes.data[i].l
        ,typeset_nodes.data[i].c,font_data.data[typeset_nodes.data[i].c].n
        ,typeset_nodes.data[i].x,typeset_nodes.data[i].y
      );
    }
  }
}

@ @<Display typesetting diagnostics@>= {
  int i;
  for(i=0;i<32;i++) {
    if(type_quan[i]) printf("%c=%d\n",i+'@@',type_quan[i]);
  }
  printf("unit_conv: %lld [%d]\n",unit_conv,round(unit_conv));
  printf("nodes: %d/%d\n",typeset_nodes.used,typeset_nodes.allocated);
  printf("fonts: %d/%d\n",font_data.used,font_data.allocated);
  if(dvi_stack) printf("stack: %d\n",dvi_stack_ptr-dvi_stack);
}

@*Process of ImageMagick. The filename of ImageMagick \.{convert} is found
by using the \.{IMCONVERT} environment variable. The entire command-line
is stored in the \.Q register, with arguments separated by spaces, and it
might be very long.

@^ImageMagick@>
@.IMCONVERT@>

@d add_magick_arg(_val) magick_args.data[new_record(magick_args)]=_val

@<Typedefs@>=
typedef char*char_ptr;

@ @<Global variables@>=
memory_of(char_ptr) magick_args;

@ @<Switch to ImageMagick@>= {
  init_memory(magick_args,4);
  add_magick_arg("convert"); // |argv[0]| (program name)
  @<Add arguments from \.Q register@>;
  add_magick_arg(0); // (terminator)
  @<Call the ImageMagick executable file@>;
}

@ The \.Q register will be clobbered here. But that is OK since it will no
longer be used within \TeX nicard.

@<Add arguments from \.Q register@>= {
  char*q=registers['Q'].text;
  char*p;
  while(q && *q) {
    p=q;
    if(q=strchr(q,' ')) *q++=0;
    if(*p) add_magick_arg(p);
  }
}

@ @<Call the ImageMagick executable file@>= {
  char*e=getenv("IMCONVERT");
  if(!e) @<Display the arguments and quit@>;
  execv(e,magick_args.data);
  fprintf(stderr,"Unable to run ImageMagick\n");
@.Unable to run ImageMagick@>
  return 1;
}

@ @<Display the arguments and quit@>= {
  data_index i;
  char*p;
  foreach(i,magick_args) if(p=magick_args.data[i]) printf("%s\n",p);
  return 0;
}

@*Internal Typesetting. Until now, we only had the codes for doing
external typesetting and image manipulation (which was the original plan
for this program). Now, we are adding internal typesetting and image
manipulation as well, to avoid external dependencies.

Some of the algorithms of \TeX\ will be used here, with some changes. For
example, there are no leaders, marks, footnotes, alignments, mathematical
formulas, or hyphenation. Ligature nodes are not needed either, because
there is no hyphenation, so we can just use normal character nodes for
ligatures.

There is also no page breaking, although you can still do vertical
splitting if you want multiple columns of text on a card, or for the text
to be interrupted in the middle.

@ Here is a list of the category codes used for internal typesetting, and
the code to initialize that table and the other tables. There are also
category codes from 32 to 255, which mean that it is a register number
containing a code to execute (we set up |tabulation| and |escape_code| to
call registers \.t and \.e, although it is unlikely to use these tokens).

@d cat_ignore 0 // Ignore this token
@d cat_norm 1 // Add a character from the current font
@d cat_space 2 // Add a glue node with the current space factor
@d cat_exit 3 // Exit the current block
@d cat_accent 4 // Add an accent to the next character
@d cat_xaccent 5 // As above, but XOR 128

@<Initialize tables for internal typesetting@>= {
  for(i=0;i<256;i++) {
    tables['E'][i]=1;
    tables['F'][i]=40;
    tables['J'][i]=tables['K'][i]=128;
  }@#
  tables['E'][null_char]=cat_ignore;
  tables['E'][end_transmission]=cat_exit; // Not actually used
  tables['E'][tabulation]='t';
  tables['E'][escape_code]='e';
  tables['E'][record_separator]=cat_exit;
  tables['E'][field_separator]=cat_exit;
  tables['E'][' ']=cat_space;
}

@ All dimensions are stored in units of scaled points (where there are
65536 scaled points in one point, and $72.27$ points in one inch).

There will also be a type for glue ratios, which is used to multiply by
glue stretch and shrink inside of a box, where a value of |0x100000000|
means 100\char`\%\relax\space stretch or shrink, or 1pt per fil unit.

@<Typedefs@>=
typedef signed int scaled;
typedef signed long long int glue_ratio;

@*Data Structures for Boxes. Typesetting is done first by storing
horizontal and vertical boxes of nodes. These boxes may then be included
in other boxes, or shipped out to the next part of the program, which is
image manipulation.

Here we list the possible kind of nodes. These are four-bit numbers, with
bit 3 set for a breakable\slash discardable node. The four high bits are
used as a small parameter for the node.

There are structures for many kinds of nodes, but only one pointer type
will be used. Unions are used to allow many kinds of nodes at once.

@d chars_node 00 // One word of text (including kerns, ligatures, accents)
@d hlist_node 01 // Horizontal box
@d vlist_node 02 // Vertical box
@d rule_node 03 // Filled rectangle
@d adjust_node 04 // Add material before or after current line
@d special_node 05 // Execute commands when this node is found
@d layer_node 06 // Like |special_node| but with only one purpose
@d kern_node 010 // Fixed movement
@d glue_node 011 // Variable movement
@d penalty_node 012 // Tell how bad it is to break a line/page here
@#
@d type_of(_node) ((_node)->type_and_subtype&0x0F)
@d subtype_of(_node) ((_node)->type_and_subtype>>4)
@s box_node int
@d calc_size(_members) (sizeof(struct{
  struct box_node*y;unsigned char z;struct{_members}@+;
}))

@<Typedefs@>=
typedef struct box_node {
  struct box_node*next; // next node, or 0
  unsigned char type_and_subtype;
  union @+{
    @<Structure of a |chars_node|@>;
    @<Structure of a |hlist_node|, |vlist_node|, or |rule_node|@>;
    @<Structure of a |adjust_node|@>;
    @<Structure of a |special_node|@>;
    @<Structure of a |layer_node|@>;
    @<Structure of a |kern_node|@>;
    @<Structure of a |glue_node|@>;
    @<Structure of a |penalty_node|@>;
  }@+;
} box_node;
@#

@ In a |chars_node|, there is a font number (0 to 255), and then sixteen
bits for each character, accent, or kern. Data |0x0000| to |0x7FFF| adds a
character (so only 32768 characters are available, while \TeX\ supports
only 256 characters, so it is still more than \TeX), data |0x8000| to
|0xBFFF| specifies an accent for the next character (so only characters
numbered 0 to 16383 can be used as accents), |0xC000| to |0xFFFE| are
implicit kerns (allowing only 16383 possible kerns, although most fonts
use only ten or so, certainly not as many as sixteen thousand), and data
|0xFFFF| is a terminator. All characters are from the same font.

If an accent is specified, it is added to the immediately next character
in this list.

@d sizeof_chars_node calc_size(unsigned char a;unsigned short b[0];)

@<Structure of a |chars_node|@>=
struct {
  unsigned char font;
  unsigned short chars[0];
}

@ An |hlist_node|, |vlist_node|, and |rule_node| are all similar to each
other, except that a |rule_node| does not have a |list| or |glue_set|, and
a |hlist_node| has an additional |tracking| parameter.

Tracking is 128 for normal width of each letter. They can be adjusted to a
lesser number to make the letters closer together, or greater to make
farther apart leters, for example 64 means half of normal width.

The |subtype_of| a |hlist_node| or |vlist_node| is the glue set order,
setting the high bit for shrinking (otherwise it is stretching).

@d sizeof_hlist_node calc_size(
  scaled a;scaled b;scaled c;scaled d;
  struct box_node*e;glue_ratio f;unsigned char g;
)
@d sizeof_vlist_node calc_size(
  scaled a;scaled b;scaled c;scaled d;
  struct box_node*e;glue_ratio f;
)
@d sizeof_rule_node calc_size(scaled a;scaled b;scaled c;scaled d;)

@<Structure of a |hlist_node|...@>=
struct {
  scaled width;
  scaled height;
  scaled depth;
  scaled shift_amount; // shift this box by the specified amount
  @#
  struct box_node*list; // pointer to first child node
  glue_ratio glue_set;
  @#
  unsigned char tracking; // adjust letter spacing
}

@ An |adjust_node| has only a pointer to the sublist, and the |subtype_of|
should be zero to append the vertical material after this line of the
paragraph, or one to put it before this line of the paragraph.

@d sizeof_adjust_node calc_size(struct box_node*a;)

@<Structure of a |adjust_node|@>=
struct {
  struct box_node*sublist; // pointer to first child node
}

@ A |special_node| contains a null-terminated C string. The |subtype_of|
specifies how it is used; they are listed below.

@d spec_measure 1 // Measuring the length of a line in a paragraph
@d spec_break 2 // Breaking a paragraph
@d spec_pack 3 // Packaging a box
@d spec_vbreak 4 // Breaking a vertical box
@d spec_render 5 // Shipping out the nodes to the page
@#
@d sizeof_special_node calc_size(char a[0];)

@<Structure of a |special_node|@>=
struct {
  char program[0];
}

@ A |layer_node| acts like a |special_node| with subtype |spec_render| and
the |program| set to |"3mL"| if the |layer| parameter is 3. It is probably
a more common kind of special.

For example, it might be used to specify typing in different colors.

@d sizeof_layer_node calc_size(unsigned char a;)

@<Structure of a |layer_node|@>=
struct {
  unsigned char layer;
}

@ A |kern_node| represents a horizontal or vertical movement, such as
where some amount of space is skipped.

@d sizeof_kern_node calc_size(scaled a;)

@<Structure of a |kern_node|@>=
struct {
  scaled distance;
}

@ A |glue_node| is similar to a |kern_node| although there are some
differences. One difference is that it can stretch and shrink. The
|subtype_of| parameter has the stretch order in the low two bits and the
shrink order in the high two bits.

@d finite 0
@d fil 1
@d fill 2
@d filll 3
@#
@d sizeof_glue_node calc_size(scaled a;scaled b;scaled c;)

@<Structure of a |glue_node|@>=
struct {
  scaled natural;
  scaled stretch;
  scaled shrink;
}

@ A |penalty_node| specifies a valid breakpoint in a paragraph, and in
addition, specifies how bad it is to break here. A penalty value 10000001
is bad enough that it will not break here, and $-10000001$ is good enough
that it will definitely break here.

@d sizeof_penalty_node calc_size(signed int a;)

@<Structure of a |penalty_node|@>=
struct {
  signed int penalty;
}

@ Here are functions for manipulation of box nodes, including creation,
destruction, and so on.

First is simple creation of a node. It sets nothing other than type and
subtype.

@-p box_node*create_node(int type,int subtype,int size) {
  box_node*ptr=malloc(size);
  ptr->next=0;
  ptr->type_and_subtype=(type&0x0F)|(subtype<<4);
  return ptr;
}

@ Now is destruction. It is recursive because some nodes are boxes that
point to other lists too.

@-p void trash_nodes(box_node*this) {
  box_node*next;
  while(this) {
    next=this->next;
    @<Recurse if there is a sublist to trash@>;
    free(this);
    this=next;
  }
}

@ @<Recurse if there is a sublist to trash@>= {
  switch(type_of(this)) {
    case hlist_node: case vlist_node: @/
      trash_nodes(this->list); @+break;
    case adjust_node: @/
      trash_nodes(this->sublist); @+break;
    default: ; // Do nothing
  }
}

@ You might realize there are no reference counts. They aren't needed,
because each node is used exactly once. (Later on in the semantic nest, it
is seen that this is not quite true; the box nest also includes a
reference, which is in addition to the |next| pointers of each node, but
this is OK since those are nodes are never isolated or destroyed when
picked off of that list.)

@*Font Metric Data. In order to do internal typesetting, it is necessary
to load the font metric data from a \.{TFM} file. The data in a \.{TFM}
file consists of 32-bit words in big-endian order.

However, the first 6 words are twelve 16-bit integers instead, giving
lengths of various parts of the file.

@s fix_word int
@ The most important data type used here is a |fix_word|, which is a
32-bit signed number, with 12 integer bits and 20 fractional bits. Most of
the |fix_word| values in a \.{TFM} file range from $-16$ to $+16$.

@<Typedefs@>=
typedef signed int fix_word;

@ The twelve lengths are according to the following:

\hbox to\hsize{\hfil\vbox{\smallskip\halign{\hfil$\it#={}$&#\hfil\cr
  lf&length of the entire file, in words\cr
  lh&number of words of header data\cr
  bc&smallest character code in this font\cr
  ec&largest character code in this font\cr
  nw&number of words in the width table\cr
  nh&number of words in the height table\cr
  nd&number of words in the depth table\cr
  ni&number of words in the italic correction table\cr
  nl&number of words in the ligature/kern program\cr
  nk&number of words in the kern table\cr
  ne&number of words in the extensible character table\cr
  np&number of font parameter words\cr
}\smallskip}\hfil}

\noindent The parts of the file are in the order listed above. Some of the
sections of the file are not used by this program (the extensible
characters and the header words), but they still must be skipped over when
reading the \.{TFM} file. Also, the $\it lf$ parameter is only for
verification, and this program does not attempt to verify it.

@ Here is data structures for storing information about font metrics. It
is a managed memory. Some elements will be shared by multiple fonts that
use the same \.{TFM} file, such as |design_size|, |fontname|, and the
ligature/kerning programs.

@<Late Typedefs@>=
typedef struct {
  scaled parameters[16]; // Font parameters (up to sixteen)
  scaled at_size; // At size, for figuring out \.{GF} filename
  scaled design_size; // Design size, for figuring out \.{GF} filename
  char*fontname; // Name of font, without extension or area
  scaled*width_base;
  scaled*height_base;
  scaled*depth_base;
  scaled*italic_base;
  scaled*kern_base;
  unsigned char min_char; // Smallest valid character code
  unsigned char max_char; // Largest valid character code
  int right_boundary; // If this is |none| then there is no right boundary
  unsigned char lig_limit; // Code |x| ligatures if |x<256*lig_limit|
  @<More elements of |font_metric_data|@>@;
} font_metric_data;

@ @<Global variables@>=
memory_of(font_metric_data) metrics;

@ @<Initialize memory@>= init_memory(metrics,4);

@ Now the ligature/kerning program. The purpose of these fields is
explained later.

@<Typedefs@>=
typedef struct {
  unsigned char skip;
  unsigned char next;
  unsigned char op;
  unsigned char remainder;
} lig_kern_command;

@ Some fonts will have a fake ``left boundary character'', which is
implied at the beginning of each word. This points to the command which
should become active at the beginning of a word. If it is null, then no
ligature/kerning program will be active.

@<More elements of |font_metric_data|@>=
  lig_kern_command*left_boundary; // Program for left boundary character

@ Another thing is the character info. These are the same data for
different sizes of the same font, since they are index into the other
arrays, which are different for each font.

@<Typedefs@>=
typedef struct {
  unsigned char width; // Index into |width_base|
  unsigned char height; // Index into |height_base|
  unsigned char depth; // Index into |depth_base|
  unsigned char italic; // Index into |italic_base|
  lig_kern_command*program; // Program for this character (null if none)
} char_info_data;

@ @<More elements of |font_metric_data|@>=
  char_info_data*info; // |info[c]| is info for character code |c|

@ So let's get started, please.

The parameter |fontnum| shall be the font number of the first size of this
font set up. The |fontname| is the name of the font, without extension.
The |at_size| parameter points to the beginning of a zero-terminated list
of at-sizes to load the font at (much of the data is the same for
different at-sizes so that we can save memory in this way). However, the
|at_size| values are |scaled|, while the \.{TFM} expects |fix_word|. This
is easy to correct by right-shifting four spaces.

The |fix_word| values are in the same format as numbers in a \.{DVI} file,
so the same code can be used. A macro is set here to make convenience.

@d get_fix_word(_fp) ((fix_word)get_dvi_number((_fp),1,4))

@-p void load_tfm(unsigned char fontnum,char*fontname,scaled*at_size) {
  char filename[max_filename_length+1];
  short lengths[12]; // The data described above, now numbered 0 to 11
  lig_kern_command*program; // Beginning of ligature/kerning program
  font_metric_data common_data; // Data common to all sizes of a font
  data_index metrics_index=metrics.used; // Index into |metrics|
  int num_sizes=0; // How many fonts we are loading at once
  int w_offset; // Offset of width table
  FILE*fp;
  @<Set up the filename of the \.{TFM} file and try to open the file@>;
  @<Load the |lengths| data@>;
  @<Set up |common_data| and |program|@>;
  @<Skip the header words@>;
  @<Load the character info@>;
  @<Set |w_offset|, and skip to the ligature/kerning program@>;
  @<Load the ligature/kerning program@>;
  @<Correct the pointers into the ligature/kerning program@>;
  @<Calculate |num_sizes| and allocate font metric structures@>;
  @<Load the dimension values for each size of this font@>;
  fclose(fp);
}

@ @<Set up the filename of the \.{TFM} file and try to open the file@>= {
  sprintf(filename,"%s.tfm",fontname);
  fp=open_file(filename,"rb");
  if(!fp) {
    fprintf(stderr,"Cannot open font %s\n",filename);
@.Cannot open font...@>
    exit(1);
  }
}

@ @<Load the |lengths| data@>= {
  int i;
  for(i=0;i<12;i++) {
    int x=fgetc(fp);
    int y=fgetc(fp);
    lengths[i]=(x<<8)|y;
  }
}

@ @<Set up |common_data| and |program|@>= {
  common_data.fontname=strdup(fontname);
  common_data.min_char=lengths[2]; // Hopefully should be zero
  common_data.max_char=lengths[3];
  common_data.right_boundary=none;
  common_data.lig_limit=255;
  common_data.info=malloc((lengths[3]+1)*sizeof(char_info_data));
  program=malloc(lengths[8]*sizeof(lig_kern_command));
}

@ @<Skip the header words@>= {
  fseek(fp,4,SEEK_CUR); // Skip checksum
  common_data.design_size=get_fix_word(fp)>>4;
  fseek(fp,4*(lengths[1]-2),SEEK_CUR); // Skip everything else
}

@ The character info is stored in a packed format. This is then unpacked
and loaded into the |common_data.info| array, which has already been
allocated.

@<Load the character info@>= {
  char_info_data*info=common_data.info+common_data.min_char;
  int i,c;
  for(i=common_data.min_char;i<=common_data.max_char;i++) {
    info->width=fgetc(fp);
    c=fgetc(fp);
    info->height=c>>4;
    info->depth=c&0xF;
    c=fgetc(fp);
    info->italic=c>>2;
    if((c&0x3)==0x1) {
      info->program=program+fgetc(fp);
    } @+else {
      info->program=0;
      fgetc(fp); // Lists and extensible recipes are not used
    }
    info++;
  }
}

@ The ligature/kerning program will be read before the dimensions specific
to the font size, so that the |common_data| can be set up first. And then
we can skip back to |w_offset|, multiple times, once for each size that is
being loaded.

@<Set |w_offset|, and skip to the ligature/kerning program@>= {
  w_offset=ftell(fp);
  fseek(fp,4*(lengths[4]+lengths[5]+lengths[6]+lengths[7]),SEEK_CUR);
}

@ @<Load the ligature/kerning program@>= {
  int i;
  for(i=0;i<lengths[8];i++) {
    program[i].skip=fgetc(fp);
    program[i].next=fgetc(fp);
    program[i].op=fgetc(fp);
    program[i].remainder=fgetc(fp);
  }
}

@ Sometimes you might need large ligature/kerning programs for many
characters, so you can start at addresses other than 0 to 255. This is the
way that specifies how that is done.

@<Correct the pointers into the ligature/kerning program@>= {
  int i;
  for(i=common_data.min_char;i<=common_data.max_char;i++)
    if(common_data.info[i].program &&
     common_data.info[i].program->skip>128)
      common_data.info[i].program=program+
       (common_data.info[i].program->op<<8)+
       common_data.info[i].program->remainder;
}

@ @<Calculate |num_sizes| and allocate font metric structures@>= {
  scaled*p=at_size;
  data_index n;
  while(*p) {
    n=new_record(metrics);
    memcpy(&(metrics.data[n]),&common_data,sizeof(font_metric_data));
    metrics.data[n].at_size=*p;
    num_sizes++;
    p++;
  }
}

@ Now to load the widths, heights, depths, italic corrections, and kerning
distances. This is what |w_offset| is for, so that we can skip back to it.
One allocated memory object is used for all dimension values of one size,
and then the points are moved into the fields of the |font_metric_data|.

@d total_font_dimen
  (lengths[4]+lengths[5]+lengths[6]+lengths[7]+lengths[9])
@d cur_metrics (metrics.data[metrics_index])

@<Load the dimension values for each size of this font@>= {
  scaled*p;
  scaled s,z,zprime,alpha,beta;
  for(p=at_size;*p;p++,metrics_index++) {
    scaled*d=malloc(sizeof(scaled)*total_font_dimen);
    int c;
    @<Ensure |d| is valid@>;
    @<Set the dimension base pointers for this font@>;
    z=*p; // The at size is now called |z|
    @<Compute |zprime|, |alpha|, and |beta|@>;
    fseek(fp,w_offset,SEEK_SET);
    c=lengths[4]+lengths[5]+lengths[6]+lengths[7];
    @<Load |c| scaled dimension values from |fp| into |d|@>;
    fseek(fp,4*lengths[8],SEEK_CUR);
    c=lengths[9];
    @<Load |c| scaled dimension values from |fp| into |d|@>;
    @<Load the font parameters@>;
  }
}

@ @<Ensure |d| is valid@>= {
  if(!d) {
    fprintf(stderr,"Out of font memory\n");
    exit(1);
  }
}

@ @<Set the dimension base pointers for this font@>= {
  cur_metrics.width_base=d;
  cur_metrics.height_base=cur_metrics.width_base+lengths[4];
  cur_metrics.depth_base=cur_metrics.height_base+lengths[5];
  cur_metrics.italic_base=cur_metrics.depth_base+lengths[6];
  cur_metrics.kern_base=cur_metrics.italic_base+lengths[7];
}

@ @<Load |c| scaled dimension values from |fp| into |d|@>= {
  while(c--) {
    scaled b3,b2,b1,b0;
    b0=fgetc(fp); @+ b1=fgetc(fp); @+ b2=fgetc(fp); @+ b3=fgetc(fp);
    *d++=(((((b3*zprime)>>8)+(b2*zprime))>>8)+(b1*zprime))/beta
     -(b0?alpha:0);
  }
}

@ Now there are font parameters. There are up to sixteen font parameters,
but numbered starting at 1. This is the code that makes it to do this.

@<Load the font parameters@>= {
  c=lengths[11]-1;
  if(c>14) c=14;
  if(c<0) c=0;
  cur_metrics.parameters[0]=cur_metrics.parameters[1]=0;
  if(lengths[11]) cur_metrics.parameters[1]=get_fix_word(fp)>>4;
  d=cur_metrics.parameters+2;
  @<Load |c| scaled dimension values from |fp| into |d|@>;
}

@*Semantic Nest. We might be building many boxes at once, nested inside of
each other. So, we need to keep the stack of what kind of boxes are
currently in use, and the associated parameters, such as space factors,
and the previous depth of the box.

There is two kinds, horizontal and vertical. The outer mode is considered
horizontal so that it does not add leading between boxes, although it is
not for making a box of the outer mode.

The currently active modes are stored both forwards and backwards, so that
we can use them as a stack of box nodes. There is a null pointer to mark
the end of the list.

@<Typedefs@>=
typedef box_node*box_node_ptr;

@ @<Global variables@>=
memory_of(box_node_ptr) box_nest;

@ @<Initialize memory@>=
init_memory(box_nest,2);

@ We also have the semantic list with local variables to the current
group. The purpose of the |data| fields depends on whether this state is
in horizontal or vertical mode, and that is why it is a union so that we
can access then by names in that case, although they can also be accessed
by numbers as well.

@<Typedefs@>=
typedef struct nest_state {
  struct nest_state*link; // Link to state this one is inside of
  boolean is_vertical; // 0 for horizontal, 1 for vertical
  data_index box_nest_index; // Index into |box_nest|
  union {
    scaled data[16];
    @<Nest state variables for horizontal mode@>;
    @<Nest state variables for vertical mode@>;
  }@+;
} nest_state;

@ @<Global variables@>=
nest_state*cur_nest;

@ @<Initialize memory@>= {
  cur_nest=malloc(sizeof(nest_state));
  cur_nest->link=0; // Means this is the outer level
  cur_nest->is_vertical=0; // Horizontal mode, no leading
  cur_nest->box_nest_index=new_record(box_nest);
  box_nest.data[cur_nest->box_nest_index]=0;
  cur_nest->space_factor=40; // Normal spacing
}

@ @<Nest state variables for horizontal mode@>=
struct {
  scaled space_factor; // Really just a number, but I don't care
}

@ @<Nest state variables for vertical mode@>=
struct {
  scaled prev_depth;
}

@ Here are codes to enter a nest.

@-p void enter_nest(boolean is_vertical) {
  nest_state*link=cur_nest;
  cur_nest=malloc(sizeof(nest_state));
  cur_nest->link=link;
  cur_nest->is_vertical=is_vertical;
  cur_nest->box_nest_index=new_record(box_nest);
  box_nest.data[cur_nest->box_nest_index]=0;
  if(is_vertical) cur_nest->prev_depth=0;
  else cur_nest->space_factor=40;
}

@ And we also need codes to leave a nest. This function returns the
pointer to the first node in the box that was being created, and then the
packaging programs can use that to make a box and iterate over the |next|
pointers to read the entire list.

@-p box_node*leave_nest(void) {
  nest_state*link=cur_nest->link;
  box_node*node;
  @<Ensure it is not nest underflow@>;
  @<Set |node| to the node at the beginning of the current list@>;
  @<Rewind |box_nest| to the end of the parent list@>;
  free(cur_nest);
  cur_nest=link;
  return node;
}

@ The outer nest should never be left or packaged; it is only used as a
general-purpose stack and a container for other nests. (Unlike \TeX, the
outer nest is never split into pages in \TeX nicard.)

@<Ensure it is not nest underflow@>= {
  if(!link) {
    fprintf(stderr,"\nNest underflow\n");
    exit(1);
  }
}

@ Note: Sometimes |node| will be a null pointer if the current list is
making an empty box (i.e. no nodes have been pushed).

@<Set |node| to the node at the beginning of the current list@>= {
  if(box_nest.used==cur_nest->box_nest_index+1) {
    node=0;
  } @+else {
    node=box_nest.data[cur_nest->box_nest_index+1];
  }
}

@ @<Rewind |box_nest| to the end of the parent list@>= {
  box_nest.used=cur_nest->box_nest_index;
}

@ And finally we have codes to push and pop nodes in the current list.
These are simple codes since there isn't much to do.

@d top_of_nodelist (box_nest.data[box_nest.used-1])

@-p inline void push_node(box_node*ptr) {
  top_of_nodelist->next=ptr;
  box_nest.data[new_record(box_nest)]=ptr;
}

@ @-p box_node*pop_node(void) {
  box_node*ptr=top_of_nodelist;
  if(ptr) {
    box_nest.used--;
    top_of_nodelist->next=0;
  }
  return ptr;
}

@*Box Calculation. Here are codes to calculate various things about the
boxes, including badness, width\slash height\slash depth of a string of
characters, and so on.

This function is used to compute the ``badness'' of a glue setting, when a
total $t$ is supposed to be made from amounts that sum to $s$. In this
program, the badness is $1000(t/s)^3$ (ten times as much as \TeX). It does
not have to be extremely accurate, although it is sufficiently accurate to
do line breaking and so on. Ten million occurs when you stretch more than
21 times as much as it should; this should never happen so it is given the
maximum possible badness that can be computed using this. The badness
squared should never exceed sixty-three bits (which it won't).

@!@^badness@>

@d very_bad 10000000
@d too_bad  10000001

@-p int calc_badness(scaled t,scaled s) {
  long long int r; // Apprximately $\root3\of{1000\cdot2^{32}}(t/s)$
  if(t==0) return 0;
  if(s<=0) return very_bad;
  r=(16255LL*t)/s;
  if(r>2097152LL) return very_bad;
  r=(r*r*r+(1LL<<31))>>32;
  if(r>very_bad) r=very_bad;
  return r;
}

@ Next we calculate the width, height, and depth of a string of
characters in one font, possibly including accents, kerns, and tracking.
Ligatures will have already been dealt with before this code is reached,
and kerns will already have been added in.

@-p void calc_chars(box_node*b,scaled*w,scaled*h,scaled*d,short t) {
  font_metric_data*m=&(metrics.data[b->font]);
  unsigned short*c; // Pointer to current character code
  scaled junk; // Ensures no segmentation faults are occuring
  if(!w) w=&junk;
  if(!h) h=&junk;
  if(!d) d=&junk;
  *w=*h=*d=0;
  for(c=b->chars;*c!=0xFFFF;c++) {
    if(*c&0x8000) {
      if(*c&0x4000) {
        @<Process an implicit kern in |calc_chars|@>;
      } @+else {
        @<Process an accent in |calc_chars|@>;
      }
    } @+else {
      @<Process a normal character in |calc_chars|@>;
    }
  }
}

@ @<Process a normal character in |calc_chars|@>= {
  scaled width=m->width_base[m->info[*c&0xFF].width];
  scaled height=m->height_base[m->info[*c&0xFF].height];
  scaled depth=m->depth_base[m->info[*c&0xFF].depth];
  if(*h<height) *h=height;
  if(*d<depth) *d=depth;
  *w+=(t*width)>>7;
}

@ @<Process an implicit kern in |calc_chars|@>= {
  scaled width=m->kern_base[*c&0x3FFF];
  *w+=(t*width)>>7;
}

@ Now to do accents. This requires looking ahead to see the height for the
next character. If the accent has positive height and zero depth, then it
should be adjusted higher in case the letter is taller than an `x' (for
example uppercase letters such as `\'E'). However, if the accent has
positive depth and zero height, then it is an accent that should not be
adjusted for the height of the character (for example `\c C'), although it
might be adjusted for the depth.

It should never happen that the next item is not a normal character (if it
does, then I am not considered responsible for your bad luck).

@<Process an accent in |calc_chars|@>= {
  scaled height=m->height_base[m->info[*c&0xFF].height];
  scaled depth=m->depth_base[m->info[*c&0xFF].depth];
  scaled c_height=m->height_base[m->info[c[1]&0xFF].height];
  scaled c_depth=m->height_base[m->info[c[1]&0xFF].depth];
  if(height<=0 && depth>0) {
    depth+=c_depth;
  } @+else {
    height+=c_height-m->parameters[5];
  }
  if(*h<height) *h=height;
  if(*d<depth) *d=depth;
}

@*Packaging. This is how the nest lists are packaged into boxes and the
width, height, and depth are calculated from them. They are separate for
horizontal and vertical packing, although there are similarities.

The packing code is also used to compute the glue set of the box, and its
badness. Here is the global variable to store the badness.

@<Global variables@>=
int last_badness=too_bad;

@ There are two such subroutines, |hpackage| and |vpackage|, depending on
what kind of box is wanted. Each one also takes three parameters: |first|,
the first node in the box; |at_size|, the intended size, and |factor|, the
amount to multiply the natural size by before adding |at_size|.

@d common_package box_node*first,scaled at_size,signed char factor

@ Horizontal packaging must compute height, width, and depth of characters
and other boxes it contains, as well as compute glue settings, specials,
adjustments, and so on.

For horizontal packaging, there is also a |tracking| parameter for spacing
the letters in the box.

@-p box_node*hpackage(common_package,unsigned char tracking) {
  box_node*box=create_node(hlist_node,0,sizeof_hlist_node);
  scaled stretchability[4]; // Total stretch of all glue
  scaled shrinkability[4]; // Total shrink of all glue
  scaled natural=0; // Total width
  box_node*this; // Current node
  @<Initialize variables for |hpackage|@>;
  @<Read all nodes in a horizontal list to package them@>;
#define @!actual @, box->width
  actual=(factor*natural)/8+at_size;
  @<Compute glue set and badness@>;
#undef actual
  return box;
}

@ @<Initialize variables for |hpackage|@>= {
  int o;
  box->list=first;
  box->tracking=tracking;
  box->height=box->depth=box->shift_amount=0;
  box->glue_set=0;
  for(o=0;o<4;o++) stretchability[o]=shrinkability[o]=0;
}

@ @<Read all nodes in a horizontal list to package them@>= {
  for(this=first;this;this=this->next) {
    switch(type_of(this)) {
      case chars_node: @<Add word to box size@>; @+break;
      case hlist_node: case vlist_node: case rule_node:
        @<Apply the size of a box to a horizontal list@>; @+break;
      case kern_node: natural+=this->distance; @+break;
      case glue_node: @<Add glue to box size@>; @+break;
      case special_node:
        if(subtype_of(this)==spec_pack) @<Pack a special node@>;
        @+break;
      default: break; // All other nodes are ignored
    }
  }
}

@ @<Add word to box size@>= {
  scaled w,h,d;
  calc_chars(this,&w,&h,&d,tracking<<1);
  natural+=w;
  if(h>box->height) box->height=h;
  if(d>box->depth) box->depth=d;
}

@ @<Apply the size of a box to a horizontal list@>= {
  natural+=this->width;
  if(this->height+this->shift_amount>box->height)
    box->height=this->height+this->shift_amount;
  if(this->depth-this->shift_amount>box->depth)
    box->depth=this->depth-this->shift_amount;
}

@ @<Add glue to box size@>= {
  natural+=this->natural;
  stretchability[subtype_of(this)&3]+=this->stretch;
  shrinkability[subtype_of(this)>>2]+=this->shrink;
}

@ When packing a special node that has a code to run during packing, it
can read and affect the current width and the intended width; it could
also do other things, such as accumulating boxes for adjustments and so
on.

@<Pack a special node@>= {
  push_num(at_size);
  push_num(natural);
  @# execute_program(this->program); @#
  natural=pop_num();
  at_size=pop_num();
}

@ A macro named |actual| is defined above so that this code can be used
for both horizontal and for vertical packaging.

We also have a macro here to decide setting the glue.

@d set_glue(_order,_flag,_diff,_glue)
  (box->type_and_subtype|=((_order)<<4)|((_flag)<<7)),
  (box->glue_set=make_fraction(_glue,_diff))

@<Compute glue set and badness@>= {
  if(actual>natural) {
    @<Glue is stretching@>;
  } @+else if(actual<natural) {
    @<Glue is shrinking@>;
  } @+else {
    last_badness=0; // Perfect!
  }
}

@ @<Glue is stretching@>= {
  if(stretching[filll]!=0) {
    set_glue(filll,0,actual-natural,stretching[filll]);
    last_badness=0;
  } @+else if(stretching[fill]!=0) {
    set_glue(fill,0,actual-natural,stretching[fill]);
    last_badness=0;
  } @+else if(stretching[fil]!=0) {
    set_glue(fil,0,actual-natural,stretching[fil]);
    last_badness=0;
  } @+else if(stretching[finite]!=0) {
    set_glue(finite,0,actual-natural,stretching[finite]);
    last_badness=calc_badness(actual-natural,stretching[finite]);
  } @+else {
    last_badness=too_bad;
  }
}

@ @<Glue is shrinking@>= {
  if(shrinking[filll]!=0) {
    set_glue(filll,1,natural-actual,shrinking[filll]);
    last_badness=0;
  } @+else if(shrinking[fill]!=0) {
    set_glue(fill,1,natural-actual,shrinking[fill]);
    last_badness=0;
  } @+else if(shrinking[fil]!=0) {
    set_glue(fil,1,natural-actual,shrinking[fil]);
    last_badness=0;
  } @+else if(shrinking[finite]>=natural-actual) {
    set_glue(finite,1,natural-actual,shrinking[finite]);
    last_badness=calc_badness(natural-actual,shrinking[finite]);
  } @+else {
    set_glue(finite,1,1,1); // Shrink as much as possible
    last_badness=too_bad;
  }
}

@ Now vertical.

For vertical packaging, the two extra parameters are |max_dp|, the maximum
depth; and |align_top|, which should be set true if it is wanted to align
at the top instead of at the bottom.

@-p box_node*vpackage(common_package,scaled max_dp,boolean align_top) {
  box_node*box=create_node(vlist_node,0,sizeof_vlist_node);
  scaled stretchability[4]; // Total stretch of all glue
  scaled shrinkability[4]; // Total shrink of all glue
  scaled natural=0; // Total height plus depth
  scaled bonnet=0; // Height of first item
  scaled boot=0; // Depth of last item
  box_node*this; // Current node
  @<Initialize variables for |vpackage|@>;
  @<Read all nodes in a vertical list to package them@>;
  box->height=bonnet; @+ box->depth=boot;
#define @!actual @, (*(align_top?&(box->depth):&(box->height)))
  natural-=align_top?bonnet:boot;
  actual=(factor*natural)/8+at_size;
  @<Compute glue set and badness@>;
#undef actual
  @<Move the reference point to match the maximum depth, if applicable@>;
  return box;
}

@ @<Initialize variables for |vpackage|@>= {
  int o;
  box->list=first;
  box->width=box->shift_amount=0;
  box->glue_set=0;
  for(o=0;o<4;o++) stretchability[o]=shrinkability[o]=0;
}

@ @<Read all nodes in a vertical list to package them@>= {
  for(this=first;this;this=this->next) {
    switch(type_of(this)) {
      case hlist_node: case vlist_node: case rule_node:
        @<Apply the size of a box to a vertical list@>; @+break;
      case kern_node: natural+=this->distance; @+boot=0; @+break;
      case glue_node: @<Add glue to box size@>; @+break;
      case special_node:
        if(subtype_of(this)==spec_pack) @<Pack a special node@>;
        @+break;
      default: break; // All other nodes are ignored
    }
    if(this==first) bonnet=natural-boot;
  }
}

@ @<Apply the size of a box to a vertical list@>= {
  natural+=this->height+(boot=this->depth);
  if(this->width+this->shift_amount>box->width)
    box->width=this->width+this->width;
}

@ @<Move the reference point to match the maximum depth, if applicable@>= {
  if(box->depth>max_dp) {
    box->height+=box->depth-max_dp;
    box->depth=max_dp;
  }
}

@*Typesetting Commands. There are various commands available in \TeX
nicard for dealing with typesetting. Another thing it does is to allow you
to enter distances using units.

@<Do a typesetting command@>= {
  int c=*++ptr;
  if((c>='0' && c<='9') || c=='.') @<Read a distance and units@>@;
  else switch(c) {
    @<Typesetting commands@>@;
  }
}

@ The following units are supported:

\halign{\quad\tt#\space\hss&(#)\hss\cr
  pt&Point\cr
  bp&Desktop publishing point\cr
  in&Inch\cr
  cm&Centimetre\cr
  mm&Millimetre\cr
  pc&Pica\cr
  qu&Quarter\cr
  em&Em width -- font specific\cr
  ex&Ex height -- font specific\cr
}

@d distance_units(_a,_b,_x,_y)
  if(c==_a && decim==_b) { num*=_x; den*=_y; }

@<Read a distance and units@>= {
  int decim=1; // Multiply denominator per step; reused for second letter
  int num=0,den=1; // Numerator and denominator to scale the units
  while((c>='0' && c<='9') || c=='.') {
    den*=decim;
    if(c=='.') decim=10;
    else num=10*num+c-'0';
    c=*++ptr;
  }
  decim=*++ptr;
  distance_units('p','t',1,1);
  distance_units('b','p',7227,7200);
  distance_units('i','n',7227,100);
  distance_units('c','m',7227,254);
  distance_units('m','m',7227,2540);
  distance_units('p','c',12,1);
  distance_units('q','u',7227,10160);
  push_num(make_fraction(num,den)>>16);
}

@*Internal Image Rendering. This program uses LodePNG to read/write PNG
files. (The LodePNG included with this program is customized to omit the
things which are not used.)

@^LodePNG@>
@^Portable Network Graphics@>

@<Include files@>=
#include "lodepng/lodepng.h"

@ Here are keeping track of the bitmaps (in PBM format) and graymaps (in
(in 8-bit PGM format). Three or four graymaps are loaded from or saved to
a PNG file and the conversion between is done at that time.

@<Global variables@>=
unsigned char*bitmap[10];
unsigned char*graymap[10];

@ @-p void execute_image_manip(image_manipulator*imp) {
  unsigned int b_row_size=((layer_width+7)>>3);
  unsigned int b_layer_size=b_row_size*layer_height;
  unsigned int g_layer_size=layer_width*layer_height;
  while(imp->data_len && imp->data[0]) {
    if(imp->data[0]<20) {
      @<Perform image manipulator command with no picture registers@>;
    } @+else if(imp->data[0]<1000) {
      @<Perform image manipulator command with one picture register@>;
    } @+else if(imp->data[0]<20000) {
      @<Perform image manipulator command with two picture registers@>;
    } @+else {
      @<Perform image manipulator command with three picture registers@>;
    }
    if(imp->next==none) return;
    imp=image_manips.data+imp->next;
  }
}

@ Here are some subroutines to initialize and discard the picture memory.

@-p void init_bitmap(int n) {
  unsigned int row_size=((layer_width+7)>>3);
  unsigned int layer_size=row_size*layer_height;
  if(bitmap[n]) return;
  memset(bitmap[n]=malloc(layer_size+1),0,layer_size);
}

@ @-p void init_graymap(int n) {
  unsigned int layer_size=layer_width*layer_height;
  if(graymap[n]) return;
  memset(graymap[n]=malloc(layer_size),0,layer_size);
}

@ @-p void trash_bitmap(int n) {
  if(bitmap[n]) free(bitmap[n]);
  bitmap[n]=0;
}

@ @-p void trash_graymap(int n) {
  if(graymap[n]) free(graymap[n]);
  graymap[n]=0;
}

@ Now we have the commands which appear in an image manipulator.

Since gamma corrections are computed here, \.{math.h} is required.

@^floating point@>

@<Include files@>=
#include <math.h>

@
@^gamma correction@>

@<Perform image manipulator command with no picture registers@>= {
  switch(imp->data[0]) {
    case 1: { // Fill multiplication table
      unsigned char*t=tables[0];
      int i,j;
      for(i=0;i<256;i++) {
        j=(i*imp->data[1])/2560;
        if(j>255) t[i]=255; else t[i]=j;
      }
      break;
    }@#
    case 2: { // Fill table by polynomial
      unsigned char*t=tables[0];
      int i,j,k,n;
      for(i=0;i<256;i++) {
        j=0;
        k=1;
        for(n=1;n<imp->data_len;n++) {
          j+=k*(int)(imp->data[n]-5120);
          k*=i;
        }
        j/=2560;
        t[i]=j;
        if(j>255) t[i]=255;
        if(j<0) t[i]=0;
      }
      break;
    }@#
    case 3: { // Fill gamma table
      unsigned char*t=tables[0];
      int i;
      double d;
      for(i=0;i<256;i++) {
        d=pow(i,0.001*(double)(imp->data[1]+1));
      }
      break;
    }@#
    case 4: { // Copy table
      unsigned char*t=tables[imp->data[1]&0x7F];
      unsigned char*u=tables[imp->data[2]&0x7F];
      int i;
      for(i=0;i<256;i++) t[i]=u[i];
    }@#
    case 5: { // Compose table
      unsigned char*t=tables[imp->data[1]&0x7F];
      unsigned char*u=tables[imp->data[2]&0x7F];
      int i;
      for(i=0;i<256;i++) t[i]=u[t[i]];
    }@#
  }
}

@<Perform image manipulator command with one picture register@>= {
  int rx=imp->data[0]%10;
  switch(imp->data[0]/10) {
    case 2: { // Clear a bitmap
      trash_bitmap(rx);
      break;
    }@#
    case 3: { // Clear a graymap
      trash_graymap(rx);
      break;
    }@#
    case 4: { // Flip a bitmap
      init_bitmap(rx);
      //TODO
      break;
    }@#
    case 5: { // Flip a graymap
      init_graymap(rx);
      //TODO
      break;
    }@#
    case 6: { // Mirror a bitmap
      init_bitmap(rx);
      //TODO
      break;
    }@#
    case 7: { // Mirror a graymap
      init_graymap(rx);
      //TODO
      break;
    }@#
    case 8: { // Fill graymap with value
      init_graymap(rx);
      memset(graymap[rx],imp->data[1],g_layer_size);
      break;
    }@#
    case 9: { // Modify graymap by table
      unsigned char*t=tables[imp->data[1]&0x7F];
      unsigned int i;
      init_graymap(rx);
      for(i=0;i<g_layer_size;i++) graymap[rx][i]=t[graymap[rx][i]];
      break;
    }@#
    case 10: { // Bitwise NOT of bitmaps
      init_bitmap(rx);
      unsigned int i;
      for(i=0;i<b_layer_size;i++) bitmap[rx][i]^=0xFF;
      break;
    }@#
    case 11: { // Shift a bitmap
      init_bitmap(rx);
      //TODO
      break;
    }@#
    case 12: { // Shift a graymap
      init_graymap(rx);
      //TODO
      break;
    }@#
  }
}

@<Perform image manipulator command with two picture registers@>= {
  int rx=imp->data[0]%10;
  int ry=(imp->data[0]/10)%10;
  switch(imp->data[0]/100) {
    case 10: { // Copy bitmap
      init_bitmap(rx); @+ init_bitmap(ry);
      memcpy(bitmap[rx],bitmap[ry],b_layer_size);
      break;
    }@#
    case 11: { // Copy graymap
      init_graymap(rx); @+ init_graymap(ry);
      memcpy(graymap[rx],graymap[ry],g_layer_size);
      break;
    }@#
    case 12: { // Select maximum of graymaps
      unsigned int i;
      init_graymap(rx); @+ init_graymap(ry);
      for(i=0;i<g_layer_size;i++) {
        if(graymap[ry][i]>graymap[rx][i]) graymap[rx][i]=graymap[ry][i];
      }
      break;
    }@#
    case 13: { // Select minimum of graymaps
      unsigned int i;
      init_graymap(rx); @+ init_graymap(ry);
      for(i=0;i<g_layer_size;i++) {
        if(graymap[ry][i]<graymap[rx][i]) graymap[rx][i]=graymap[ry][i];
      }
      break;
    }@#
    case 14: { // Bitwise AND of bitmaps
      init_bitmap(rx);
      init_bitmap(ry);
      unsigned int i;
      for(i=0;i<b_layer_size;i++) bitmap[rx][i]&=bitmap[ry][i];
      break;
    }@#
    case 15: { // Bitwise OR of bitmaps
      init_bitmap(rx);
      init_bitmap(ry);
      unsigned int i;
      for(i=0;i<b_layer_size;i++) bitmap[rx][i]|=bitmap[ry][i];
      break;
    }@#
    case 16: { // Bitwise XOR of bitmaps
      init_bitmap(rx);
      init_bitmap(ry);
      unsigned int i;
      for(i=0;i<b_layer_size;i++) bitmap[rx][i]^=bitmap[ry][i];
      break;
    }@#
    case 17: { // Copy bitmap to graymap
      init_bitmap(rx);
      init_graymap(ry);
      // TODO
      break;
    }@#
    case 18: { // Blur graymap by graymap
      init_graymap(rx);
      init_graymap(ry);
      // TODO
      break;
    }@#
  }
}

@ @<Perform image manipulator command with three picture registers@>= {
  int rx=imp->data[0]%10;
  int ry=(imp->data[0]/10)%10;
  int rz=(imp->data[0]/100)%10;
  switch(imp->data[0]/1000) {
    case 20: { // Compose graymap to graymap with alpha channel
      init_graymap(rx); @+ init_graymap(ry); @+ init_graymap(rz);
      // TODO
      break;
    }@#
    case 21: { // Apply color transformation matrix
      init_graymap(rx); @+ init_graymap(ry); @+ init_graymap(rz);
      // TODO
      break;
    }@#
  }
}

@*Main Program. This is where the program starts and ends. Everything else
in the other chapters is started from here.

@<Include files@>=
#include <signal.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>
#include <unistd.h>

@ @-p int main(int argc,char**argv) {
  boolean dvi_mode=0;
  @<Set up signal handler@>;
  @<Initialize memory@>;
  @<Display the banner message@>;
  @<Decide whether in DVI reading mode@>;
  if(!dvi_mode) @<Open the main input file@>;
  @<Initialize the input states@>;
  @<Initialize the tables and registers@>;
  @<Initialize the random number generator@>;
  @<Set registers according to command-line parameters@>;
  if(!dvi_mode) @<Process the input files@>;
  if(dvi_mode) dvi_mode=read_dvi_file(argv[1]);
  @<Call program in \.Z register if necessary@>;
  if(!dvi_mode) @<Send |end_transmission| to each card area@>;
  @<Write the output files@>;
  if(registers['Q'].is_string && dvi_mode &&
    (argv[0][0]!='-' || argv[0][1]!='z'))  @<Switch to ImageMagick@>;
  return 0;
}

@ @<Display the banner message@>= {
  fprintf(stderr,"TeXnicard version %s\n",version_string);
  fprintf(stderr,
    "This program is free software and comes with NO WARRANTY.\n");
  fflush(stderr);
}

@ @<Set registers according to command-line parameters@>= {
  int i;
  for(i=2;i<argc;i++) {
    registers[i+('0'-2)].is_string=1;
    registers[i+('0'-2)].text=strdup(argv[i]);
  }
}

@ The main input file will be either the terminal, or another file if the
command-line argument is given.

@<Open the main input file@>= {
  if(argc>1 && strcmp(argv[1],"-")!=0) {
    --current_input_file;
    open_input(argv[1]);
  } @+else {
    current_fp=0;
    strcpy(current_filename,"<Teletype>");
  }
}

@ @<Call program in \.Z register if necessary@>= {
  if(registers['Z'].is_string) execute_program(registers['Z'].text);
}

@ The alternative mode to run this program is DVI mode. DVI mode is
specified by a command-line switch.

@.DVI@>

@<Decide whether in DVI reading mode@>= {
  if(argc>1 && argv[1][0]=='-' && argv[1][1]) {
    dvi_mode=1;
    argv++; @+ argc--;
    if(argv[0][1]=='a') {
      printing_mode=printing_all_cards;
    } @+else if(argv[0][1]=='f') {
      printing_mode=printing_list_from_file;
      printlistfile=fopen(argv[1],"r");
      argv++; @+ argc--;
    } @+else if(argv[0][1]=='n') {
      printing_mode=printing_list;
      printlisttext=argv[1];
      argv++; @+ argc--;
    } @+else if(argv[0][1]=='z') {
      printing_mode=printing_list;
      printlisttext="";
    }
  }
}

@*Signal Handlers. The |SIGSEGV| signal should be handled in case
something goes wrong in the program and it causes a segmentation fault, it
should attempt to recover what you have before terminating, in order to be
better at diagnosing the error.

@<Set up signal handler@>= {
  signal(SIGSEGV,handle_crash);
}

@ Some things will be more careful here to ensure not to cause the error
again (if it does, it will just quit, though).

@-p void handle_crash(int sig) {
  signal(SIGSEGV,SIG_DFL);
  @#fprintf(stderr,"\nFatal signal error (%d)\n",sig);
@.Fatal signal error...@>
  fprintf(stderr,"cur_state=%d\ncur_name=%d\ncur_data=%d\n",
   cur_state,cur_name,cur_data);
  if(current_input_file>=input_files && current_input_file<input_files
   +max_input_stack) @<Display input stack after a crash@>;
  fprintf(stderr,"Program stack level: %d\n",stack_ptr-stack);
  fprintf(stderr,"Save stack level: %d\n",save_stack_ptr-save_stack);
  @#exit(3);
}

@ @<Display input stack after a crash@>= {
  for(;;) {
    fprintf(stderr,"File %s line %d\n",current_filename,current_line);
    if(current_input_file--==input_files) break;
  }
}

@*The Future. Here are some ideas for future versions of this program:

$\bullet$ A customizable Inform7-like parser, that would compile into a C
code (or possibly a Haskell code), so that you can play the cards on
rule-enforcing computer programs.
@^Inform@>

$\bullet$ A database to keep track of how many copies of a card have been
sold, for inventory purposes.
@^commercial viability@>
@^inventory@>

$\bullet$ Full text search, for things such as the Oracle text search.
@^Oracle@>

$\bullet$ Allow more than 256 fonts in one card set.

$\bullet$ Unicode input (UTF-8).

@*Bibliography.

\count255=0 %
\long\def\Par{\csname par\endcsname}%
\loop\ifnum\count255<\bibliocount%
  \advance\count255 by 1
  \Par$^{[\the\count255]}$\csname biblio \the\count255\endcsname\Par%
\repeat%

@*Index. Here you can find references to the definition and use of all the
variables, subroutines, etc.\ used in this program, as well as a few other
things of interest. Underlined entries indicate where it is defined.

{\bf Important note:} All the numbers in this index are section numbers,
not page numbers.

% End of file "texnicard.w"