~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

       Generating List Mapping Predicates

program_list_map( Predicate_name,
                  Element_predicate) :-
                % build the head for the null list rule
         Null_list_rule_head =.. [ Predicate_name, [] , [] ],
                % assert the null list rule, including a cut
         asserta(( Null_list_rule_head  :- !)),
                % build recursive rule head
         Recursive_rule_head =.. [ Predicate_name, [H | T] , [H1 | T1] ],
                % build call for Element_predicate
         Element_predicate_call =.. [ Element_predicate , H, H1 ],
                % build recursive call
         Recursive_call =.. [ Predicate_name , T, T1 ],
                % assert recursive rule
         assertz( ( Recursive_rule_head :-
                           Element_predicate_call,
                           Recursive_call )).


                  Box 1

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

               A Program Scheme with Comments

      $  /*  Predicate_name User_defined_purpose */
          /*  Predicate_name maps null set into null set */
       Predicate_name( [], []) :- !.
          /*  recursive rule for Predicate_name */
       Predicate_name( [H|T], [H1|T1]) :-
                 /* apply Element_predicate to head of list */
              Element_predicate( H, H1),
                 /* recurse with Predicate_name on tail of list */
              Predicate_name(T, T1).   $,


                     Box 2

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

       Information in a Programmer's Scheme

[comment([$/*$, var($Predicate_name$),
                var($User_defined_purpose$), $*/$]),
 comment([$/*$, var($Predicate_name$),
                $maps$, $null$, $set$, $into$, $null$, $set$, $*/$]),
 rule((var_functor_term(var($Predicate_name$),[[],[]]) :- [$!$])),
 comment([$/*$,$recursive$,$rule$,$for$,var($Predicate_name$),$*/$]),
 rule((var_functor_term(var($Predicate_name$),
                            [[var($H$) | var($T$)],
                             [var($H1$) | var($T1$)]]) :-
         [ comment([$/*$, $apply$, var($Element_predicate$),
                          $to$, $head$, $of$, $list$, $*/$]),
           var_functor_term(var($Predicate_name$),
                             [var($H1$) ,  var($H1$)]),
           comment([$/*$, $recurse$, $with$,
                          var($Predicate_name$), $*/$]),
           var_functor_term(var($Predicate_name$),
                            [var($T1$) ,  var($T1$)]) ]))]

                  Box 4

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


           A BNF for Prolog Program Schemes

     % a schema definition is a list of items (clauses or comments)
scheme_def --> item | scheme_def | []

     % an item is a clause or comment
item --> clause | comment

     % an clause is a fact or rule
clause --> fact | rule

     % a fact is a term followed by a period
fact --> term .

     % a rule is a term (the head) followed by the neck symbol
     % followed by a (rule) body followed by a period
rule --> term :- body .

     % a body is a comment followed by body
     % or a term followed by a comma followed by a body
     % or a term or a comment
body --> comment body | term , body | term  | comment

     % a term is a functor symbol followed by an argument list
     % or a set or a constant or a variable
term --> functor_symbol arg_list | set | constant | variable

     % an arg_list is a term_list in parens
arg_list --> ( termlist )

     % a term_list is a term followed by a ter_list or a term
term_list --> term term_list | term

     % a functor symbol is an atom or variable
functor_symbol --> atom | variable

     % a set is a list of terms or the empty list
set  --> [ set_termlist  | []

     % a termlist is a term followed by a comma followed by a termlist
     % or a term followed by a right bracket
     % or a term, a bar, a term, and a right bracket
set_termlist --> term, set_termlist | term  ] |  term bar term ]

     % def. of bar
bar --> |

     % a comment is a comment starter followed by a (comment)
     % word list
comment        --> start_comment word_list

     % a word_list is a word followed by a word_list
     % or an end of comment
word_list      --> word word_list | end_comment

     % a word is a variable or a token
word           --> variable | token

start_comment  --> /*

end_comment    --> */

                  Box 5

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

          A Definite Clause Grammar for Schemes


scheme_def(Scheme) --> item(H), scheme_def( T),
                         {Scheme= [ H | T],
                          p_trace($Scheme : $, Scheme)},!.
scheme_def([],[],[]) :- p_trace($Scheme = [] $),!.

item(X) --> fact(X) , !,{p_trace($item : $, X)}.
item(X) --> rule(X) , !,{p_trace($item : $, X)}.
item(X) --> comment(X) , !,{p_trace($item : $, X)}.

fact(fact(Fact)) --> term( Fact), [$.$],
                     {p_trace($Fact : $,Fact)}.

rule(Rule) --> term(Head), [$:-$],
               {p_trace($starting rule body$)},
               body(Body),
               {Rule = rule((Head :- Body)),
                p_trace($Rule : $,Rule)}.

body( Body ) -->   comment(H), body(T),!,
                   { Body = [H | T],
                     p_trace($Body : $,Body)}.
body( Body ) -->   term(H), [$,$], body(T),!,
                   { Body = [H | T],
                     p_trace($Body : $,Body)}.
body( [Term]) -->  term( Term), [$.$],!,
                   {p_trace($Body : $, Term)}.
body( [Comment]) -->  comment(Comment), [$.$],!,
                      {p_trace($Body : $, Comment)}.

     % a term is a functor symbol followed by an argument list
     % or a set or a constant or a variable or a set
term(Term) --> variable(Variable), [$($],
               {p_trace($entering arg_list $)},
               arg_list(Arg_list), !,
               {Term = var_functor_term( Variable, Arg_list),
                p_trace($term: $,Term)}.

term(Term) --> is_atom(X), [$($], arg_list(Arg_list), !,
               {Term = const_functor_term( X, Arg_list),
                p_trace($term: $,Term)}.

term(X) --> set(X), ! , { p_trace($term: $,X)}.

term(X) --> is_atomic(X), ! , { p_trace($term: $,X)}.

term(X) --> variable(X), ! , { p_trace($term: $,X)}.

arg_list(Arglist = [Term | Termlist]) --> term(Term) ,
                                arg_list_hlpr(Termlist),!,
                                { Arglist = [Term | Termlist],
                                  p_trace($arg_list: $,Arglist)}.

arg_list_hlpr([]) -->  [$)$] , !,
                       { p_trace($arg_list_hlpr: []$)}.
arg_list_hlpr(Termlist) --> [$,$] , arg_list( Termlist) , !,
                       { p_trace($arg_list_hlpr: $,
                                 Termlist )}.

     % set  --> [ termlist
set( Set ) --> [$[$], termlist(Set),!,{p_trace($Set : $,Set)}.
     % set  --> [ ]
set( Set ) --> [$[$,$]$],{Set = [], p_trace($Set : $,Set)}.

termlist(Termlist) --> term(H), termlist_hlpr(T),
                       { Termlist = [H | T],
                        p_trace($termlist : $, Termlist)}.
termlist_hlpr([]) --> [$]$],!,{p_trace($termlist : []$)}.
termlist_hlpr(T) --> [$|$], term(T),[$]$],!,
                     {p_trace($termlist : $, T)}.
termlist_hlpr(T) --> comma($,$), termlist(T), !,
                     {p_trace($termlist : $, T)}.

comment( Comment ) --> start_comment( H), word_list(T),
                                { Comment = comment([H | T]),
                                  p_trace($Comment : $,Comment) }.

        % the straightforward implementation, like that of
        % start_comment, did not work properly
end_comment($*/$) --> [$*/$].

start_comment($/*$) --> [$/*$].

          % word_list --> word word_list | end_comment
word_list( [H | T] ) --> word(H), word_list( T ), !.
word_list( [H] ) --> end_comment( H ).

          % word --> variable | token
word(X) --> variable(X),!.
          % don't let an end of comment be a word
word(X) --> end_comment(X), !, {fail}.
word(X) --> token(X).

          % returns a variable inside a var(*) marker
variable(var(X)) --> [X], % get the next token
                     % get its first character
                {nth_char(0,X,Char),
                     % see if it's upper case
                 is_uc(Char)}.

           % get an atom from input stream
is_atom(X)  --> [X], % get the next token
                   % get its first character
               {nth_char(0,X,Char),
                   % see if it's lower case
               is_lc(Char)}.

           % get an atomic structure from input stream
is_atomic(X)  --> [X], % get the next token
                   % see if it's atomic
                  {atomic(X)},!.

comma(X) --> [$,$],!.

     % returns an arbitrary token as itself
token(X) --> [X],!.


                        Box 6

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

               A User-Supplied Scheme Fact

scheme( program_list_map,

      $  /*  Predicate_name User_defined_purpose */
               .......................
           < complete scheme from Box 2 goes here>
               .......................
              Predicate_name(T, T1).   $,

     [ $Predicate_name$ : $name of predicate to be defined$,
       $User_defined_purpose$ :
             $description of what the predicate does$,
       $Element_predicate$ : $predicate that maps set elements$]).

                     Box 7
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

         Converting a Scheme to Internal Form

preprocess( scheme( Name, Scheme, Table),
            internal_scheme( Name, Internal_Scheme,
                             Table) :-
               % tokenize the input
            tokenize(Scheme,  Tokens),
               % build scheme semantic structure
            scheme_def( Internal_Scheme, Tokens, []).

                      Box 8

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

               Top Level of Code Generation

         % generate code from a scheme given its name
process( Scheme_name) :-
          % look up internal scheme
     internal_scheme( Name, Internal_Scheme,
                      Table),
          % get the values of variables in Table,
     get_variable_values(Table, Values),
          % get temporary file for code
      temporary_file_handle(Temp_file_name, Temp_file_handle),
          % get the file name where the code should go permanently
      get_destination_file(Peramanent_filename),
          % generate the code
      generate_code(Temp_file_handle, Values, Internal_Scheme),
          % close temp file
      close( Temp_file_handle ),
          % append code to the permanent file
      append_files( Temp_file_name, Peramanent_filename).


     % get the values of variables in a scheme Table
get_variable_values(Table, Values) :-
         % get Table in reverse order to make questions
         % come out in forward order during recursion
      reverse(Table, Reversed_table),
         % ask questions and build frame of variable values
      ask_questions( Reversed_table, Values0),
         % put attribautes back in original order
      reverse(Values0, Values).

         % ask questions and build frame of variable values
ask_questions( [], [] ) :- !.
ask_questions( [H | T], [H1 | T1] ) :-
          ask_question(H , H1),
          ask_questions(T , T1).

         % ask the user a question
ask_question(  Variable : Question,
                Variable : Value) :-
                % write question to screen
          write( Question),write($ ? $),
                % read user response
          read_line(1, Value).

    % append File2 to File1
append_files( File1, File2) :-
             % build a DOS copy command that appends files
         concat([$copy $,File1,$+$,File2,$,$,File1],Cmd),
             % send it to DOS
         shell(Cmd).

                  Box 10

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

             Code Generation

          % generate the output code.  Scheme is input stream.
          % This is written as a Prolog predicate instead of
          % a grammar rule because of a suspected bug in the DCG
          % translator
generate_code_hlpr(Temp_file_handle, Values,
                      % does the input start with a comment
                   [comment(X) | Rest],
                   Left_over) :-
          o_trace($e generate_code_hlpr$),
                  % generate initial comment with 0 indent
          generate_comment( Temp_file_handle, Values, 0,
                            [comment(X)],[]),!,
                   % blank line after this comment
         nl(Temp_file_handle),
         o_trace($a initial comment$),
          % generate each clause in turn
         generate_clauses( Temp_file_handle, Values,
                           Rest, Left_over).

generate_code_hlpr(Temp_file_handle, Values) -->
          % otherwise just generate clauses
       generate_clauses( Temp_file_handle, Values).


generate_comment( Handle, Values, Offset) -->
       {o_trace($e generate_comment$)},
       [comment([$/*$ | X])],
       { nl(Handle), tab(Handle,Offset), write(Handle, $/*$),
         generate_comment_hlpr( Handle,
                                 Values, X, [])},!.

generate_comment_hlpr( Handle, Values) -->
              [$*/$],{write_spaced_token(Handle,$*/$)},!.
generate_comment_hlpr( Handle, Values) -->
              scheme_token( Values, Value),
              {write_spaced_token(Handle, Value)},
              generate_comment_hlpr( Handle, Values).

write_spaced_token(Handle, Value) :-
          tab(Handle, 1), write(Handle, Value).

scheme_token( Values, Value) -->
     [var(Indicator)],!,
     {get_frame_value_with_default(Values, Indicator,
                                   Indicator, Value),
      o_trace($Token = $,Value)}.
scheme_token( Values, Value) -->  [Value],
      {o_trace($Token = $, Value)}.


%%%%%%%%%%%%%%%%%%% tests %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

test :- generate_code(1,   % put output to screen for test
                % Here are the values of the template variables
          [$Predicate_name$ :  list_of_types,
           $User_defined_purpose$ :
   $maps a list into a list of types elementwise$,
           $Element_predicate$ :  type],
                % Here is the processed template
[comment([$/*$, var($Predicate_name$),
                var($User_defined_purpose$), $*/$]),
 comment([$/*$, var($Predicate_name$),
                $maps$, $null$, $set$, $into$, $null$, $set$, $*/$]),
 rule((var_functor_term(var($Predicate_name$),[[],[]]) :- [$!$])),
 comment([$/*$,$recursive$,$rule$,$for$,var($Predicate_name$),$*/$]),
 rule((var_functor_term(var($Predicate_name$),
                            [[var($H$) | var($T$)],
                             [var($H1$) | var($T1$)]]) :-
         [ comment([$/*$, $apply$, var($Element_predicate$),
                          $to$, $head$, $of$, $list$, $*/$]),
           var_functor_term(var($Element_predicate$),
                             [var($H1$) ,  var($H1$)]),
           comment([$/*$, $recurse$, $with$,
                          var($Predicate_name$), $*/$]),
           var_functor_term(var($Predicate_name$),
                            [var($T1$) ,  var($T1$)]) ]))]
         ).

                  Box 11

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

                Retrieval from Frames


/* This predicate gets a Value from a Frame given an Indicator
   (slot name).  It gets the Value stored in the frame if there
   is one, and Default otherwise.
*/
          % rule after frame is searched
get_frame_value_with_default( [], _, Default, Default) :-!.
          % rule for when the value is in the first pair
get_frame_value_with_default( [Indicator : Value | _],
                               Indicator, _, Value):- !.
          % recursive rule
get_frame_value_with_default( [_|T], Indicator, Default, Value) :-
     get_frame_value_with_default( T, Indicator, Default, Value).


                 Box 12

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

               A Test of the Code Generator

/* Here is the test: the box 2 template with some scheme
   variable values.  */

test :- generate_code(1,   % put output to screen for test
                % Here are the values of the template variables
          [$Predicate_name$ :  list_of_types,
           $User_defined_purpose$ :
   $maps a list into a list of types elementwise$,
           $Element_predicate$ :  type],
                % Here is the processed template
[comment([$/*$, var($Predicate_name$),
                var($User_defined_purpose$), $*/$]),
 comment([$/*$, var($Predicate_name$),
                $maps$, $null$, $set$, $into$, $null$, $set$, $*/$]),
 rule((var_functor_term(var($Predicate_name$),[[],[]]) :- [$!$])),
 comment([$/*$,$recursive$,$rule$,$for$,var($Predicate_name$),$*/$]),
 rule((var_functor_term(var($Predicate_name$),
                            [[var($H$) | var($T$)],
                             [var($H1$) | var($T1$)]]) :-
         [ comment([$/*$, $apply$, var($Element_predicate$),
                          $to$, $head$, $of$, $list$, $*/$]),
           var_functor_term(var($Element_predicate$),
                             [var($H1$) ,  var($H1$)]),
           comment([$/*$, $recurse$, $with$,
                          var($Predicate_name$), $*/$]),
           var_functor_term(var($Predicate_name$),
                            [var($T1$) ,  var($T1$)]) ]))]
         ).


/*  Here is the generated code:  */

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


/* list_of_types maps a list into a list of types elementwise */

          /* list_of_types maps null set into null set */
list_of_types([], []) :-
                    !.

          /* recursive rule for list_of_types */
list_of_types([H | T], [H1 | T1]) :-
                    /* apply type to head of list */
                    type(H1, H1),
                    /* recurse with list_of_types */
                    list_of_types(T1, T1).



%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


               Box 13

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

          A Scheme for Selecting a Scheme

internal_scheme(
      sort,
      [$memory_size$ : $how much memory do you have$,
       $sort_size$ : $how many items do you have to sort$,
       $item_size$ : $how big is each item$],
      sort_helper).

sort_helper( Variables) :-
      get_frame_value(Variables, $memory_size$, Memory),
      get_frame_value(Variables, $sort_size$, Items),
      get_frame_value(Variables, $item_size$, Size),
      select_sort( Memory, Items, Size).

select_sort( Memory, Items, Size) :-
       Size < 20,
       process(insert_sort).

select_sort( Memory, Items, Size) :-
       Required is Items * Size + 10E5,
       Memory > Required,
       process(quick_sort).

select_sort( _, _, _) :-
       process(merge_sort).

                Box 14

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


       process(merge_sort).

                Box 14

~~~~~~~~~~~~~~~~~~~~~~