Function composition

[TeXnicard.git] / texnicard.w

% TeXnicard
% version 0.1

% Licensed by GNU GPL v3 or later version.

\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
\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}%
}%

@*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");
  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

@<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);
    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);
  }
}

@*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]) *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;
      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;
  }@#

@ @<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.

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

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 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 '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;
    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.

@d no_sort 0
@d primary_ascending 'A'
@d primary_descending 'Z'
@d secondary_ascending 'a'
@d secondary_descending 'z'
@d record_sorted_position 'R'
@#
@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) {
      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;
    }
  }
  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;
    }
  }
}

@ 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.

@<Mark positions in the sorted list@>= {
  data_index i;
  int j;
  for(j=0;j<16;j++) {
    if(G_table(j)==record_sorted_position) {
      foreach(i,card_list) card_list.data[i].field[j]=i;
    }
  }
}

@ @<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<16;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;
}

@*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.

@<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 pattern_state 'P'
@d subroutine_state 'S'
@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 in order to open another input file. One way is
that the file might be included from another file, or it might be the
main file.

@-p void open_input(char*name) {
  if(++current_input_file>input_files+max_input_stack) {
    fprintf(stderr,"Too many simultaneous input files\n");
    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);
    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 '>': /* Do nothing */ @+break;
    default: @/
      if((*ptr>='A' && *ptr<='Z') || (*ptr>='0' && *ptr<='9')) {
        @<Enter a |heading| state@>;
      } @+else {
        parsing_error("Unknown @@ command");
      }
  }
}

@ 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 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 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
    if(stack_ptr->is_string) program_error("Type mismatch");
    cur_state=pop_num()|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@>= {
  char searchpath[max_pathname_length+max_filename_length+1];
  char*cpath;
  char*npath=getenv("TEXNICARDPATH");
  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@>;
  @<It is a fatal error if no such file was found@>;
}

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

@ @<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);
    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);
  }
}

@*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);
  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");
  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=is_signed?-1:0;
  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))
@d make_fraction(_n,_d) ((dvi_measure)(to_measure(_n)/(_d)))

@*GF Reading.

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 next chapter), which makes it very convenient.

@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 [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|

@*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 void read_dvi_file(char*filename) {
  FILE*fp=fopen(filename,"rb");
  if(!fp) dvi_error(fp,"Unable to open file");
  @#@<Skip the preamble of the \.{DVI} file@>;
  @<Compute the conversion factor@>;
  @<Skip to the next page@>;
  @<Read the metapage heading@>;
  read_dvi_page();
  @<Skip to and read the postamble@>;
  @<Read the font definitions and load the fonts@>;
  @#fclose(fp);
}

@ @-p void dvi_error(FILE*fp,char*text) {
  fprintf(stderr,"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@>;
}

@ @<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);
}

@ 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@>= {
  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)+1,SEEK_SET);
  last_page_ptr=get_dvi_number(fp,0,4);
  fseek(fp,24,SEEK_CUR); // Skipped parameters of |post|
}

@ 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) {
      fseek(fp,c+13-fnt_def1,SEEK_CUR);
      @<Skip the font filename before a page@>;
    } @+else if(c!=nop) {
      fprintf(stderr,"Bad command between pages.\n");
      exit(1);
    }
  }
}

@ @<Skip the font filename before a page@>= {
  int a=fgetc(fp);
  int 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);
    exit(1);
  }
  push_num(get_dvi_number(fp,0,4)); @+ store('D');
  fseek(fp,9*4,SEEK_CUR); // Skip other parameters
}

@ 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;
int dvi_stack_count;

@ 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(void) {
}

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

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

@<Global variables@>=
dvi_number unit_num; // Numerator for units of measurement
dvi_number unit_den; // Denominator for units of measurement
dvi_number 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.

\.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|.

@d resolution (registers['D'])

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

@*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
  unsigned short f; // Font number, |0xFFFF| for a rule
  union {
    struct {
      unsigned short w; // Width of rule
      unsigned short h; // Height of rule
    }@+;
    unsigned int c; // Character number in current font
  }@+;
  unsigned char l; // Layer
} typeset_node;

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

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

@ 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)

@-p void typeset_rule(int x,int y,int w,int h) {
  data_index n=new_record(typeset_nodes);
  typeset_nodes.data[n].x=x;
  typeset_nodes.data[n].y=y;
  typeset_nodes.data[n].f=0xFFFF;
  typeset_nodes.data[n].w=w;
  typeset_nodes.data[n].h=h;
  typeset_nodes.data[n].l=quan('L');
}

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

@*Layer Output. 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;
  fprintf(fp,"P4%d %d ",layer_width,layer_height);
  fclose(fp);
}

@*Process of ImageMagick.

@^ImageMagick@>

@*Main Program. This is where the program starts and ends. Everything else
in the other chapters is started from here.

@<Include files@>=
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <time.h>

@ @-p int main(int argc,char**argv) {
  @<Initialize memory@>;
  @<Display the banner message@>;
  @<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@>;
  @<Process the input files@>;
  @<Call program in \.Z register if necessary@>;
  @<Send |end_transmission| to each card area@>;
  @<Write the output files@>;
  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 Future. Here are some ideas for future versions of this program:

$\bullet$ A customizable Inform7-like parser, that would compile into a C
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@>

$\bullet$ Full text search, for things such as the Oracle text search.
@^Oracle@>

$\bullet$ Big spider!
@^arachnids@>
@^spider@>

@*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"