TEACH SETS2.ANS                                    Aaron Sloman Feb 1984
                           Tidied up, and brought up to date, 7 Dec 1996

Changes in Dec 1996 include:
    (a) removing spurious lvars declarations for input and output
        locals

    (b) using "!" in the examples based on the matcher, but
        reducing the use of the matcher

    (c) some comments on the functional style

    (d) a few other changes

    (e) revised solutions to the subculture problem.


                   Sample answers to TEACH * SETS2
                   ===============================

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

 -- A COLLECTION OF PREDICATES
 -- . Using partial application to define positive and negative
 -- MUCHLESS
 -- ISSUBSET
 -- REDUNDANT
 -- EXISTS
 -- FINDONE
 -- ALL
 -- HASODD HASEVEN ALLODD ALLEVEN
 -- FINDALL
 -- PRUNE
 -- UNION
 -- INTERSECTION
 -- LARGER
 -- HOWMANY
 -- MORE
 -- MOST
 -- REMOVEALL
 -- SUBTRACT
 -- OVERLAPS EXCLUDES
 -- SUBCULTURE
 -- . subculture version 1
 -- . Test cases for subculture
 -- . subculture version 2
 -- . subculture version 4
 -- . subculture version 5
 -- QUESTION 24

-- A COLLECTION OF PREDICATES -----------------------------------------

The procedure positive takes a number and returns true if the number
is positive, i.e. greater than 0. This can be defined in a number
of different styles, some more verbose than others, and with or without
an output variable. Using an output variable is more verbose but makes
it clearer what the procedure does, when someone reads the program.

define positive(item) -> boolean;
    ;;; verbose version, with header clearly showing what the procedure
    ;;; is about
    if item > 0 then
        true -> boolean
    else
        false -> boolean
    endif;
enddefine;

define positive(item) -> boolean;
    ;;; Slightly more compact version. Evaluate conditional, then
    ;;; assign the result to the output local
    if item > 0 then
        true
    else
        false
    endif -> boolean;
enddefine;

define positive(item) -> boolean;
    ;;; Even more compact version - assign the result of ">" to
    ;;; the output local

    item > 0 -> boolean
enddefine;


define positive(item);
    ;;; Functional style of programming.
    ;;; Just leave the result of ">" as the result of this procedure.
    item > 0
enddefine;


;;; Each of the following could also be done in all the above styles.

define negative(item) -> boolean;
    item < 0 -> boolean
enddefine;

define even(item) -> boolean;
    (item mod 2) == 0 -> boolean;
enddefine;


Note: for comparing words or integers or constant items like [], it is
slightly to use "==" than "=".

This has nothing to do with the use of "=" and "==" in lists patterns.
See HELP * EQUAL for more on this.

NEVER use "==" to compare decimal numbers. (Floats).

define odd(item) -> boolean;
    (item mod 2) /== 0 -> boolean
enddefine;

-- . Using partial application to define positive and negative

Skip to next subheading if you don't know about 'partial application'.

If you have learnt about 'partial application' (see HELP * CLOSURES or
the second half of TEACH PERCENT, or HELP PARTAPPLY),
then you could have defined positive and negative by partially applying
the operators > and < to 0.

There are two points to note. One is that partial application uses
(% .. %) for the arguments to the procedure to say, do not run this
procedure now but create a new version which can be run later and will
already have these arguments. The other point is that because ">" and
"<" are names of infix operators, you have to use "nonop" in front of
them to prevent pop-11 immediately trying to run the corresponding
procedures.

vars positive;

nonop >(%0%)    -> positive;        ;;; partially apply ">" to 0

vars, negative;

nonop <(%0%)    -> negative;        ;;; partially apply "<" to 0

The nonop part is there to stop the procedure > (or <) actually attempting
to run, which it would normally do since it is an 'infix' operator.

Those declarations and assignments can be combined, thus:

vars
    positive = nonop >(%0%),

    negative = nonop <(%0%);

Alternatively you can use this format

define positive = nonop >(%0%)
enddefine;

define negative = nonop <(%0%)
enddefine;

/*
;;; tests

positive(6) =>
positive(-6) =>
positive(0) =>
positive(4.5) =>

negative(6) =>
negative(-6) =>
negative(0) =>
negative(4.5) =>

*/

Note that according to those definitions 0 is neither positive nor
negative.

-- MUCHLESS -----------------------------------------------------------

define muchless(num1, num2) -> boole;
    num2 - num1 > 100 -> boole;
enddefine;

-- ISSUBSET -----------------------------------------------------------

define issubset(list1, list2) -> boolean;

    lvars item;
    for item in list1 do
        unless member(item, list2) then
            ;;; Item from list1 not in list2, so
            false -> boolean; return()
        endunless
    endfor;
    ;;; Everything in list1 was found to be in list2, so
    true -> boolean;
enddefine;


;;; Here is a version using "returnunless" in this format
;;; returnunless( <condition> )( <action> )
;;;; Meaning unless <condition> then <action>; return() endunless;

define issubset(list1, list2) -> boolean;
    lvars item;
    for item in list1 do
        returnunless( member(item, list2) )(false -> boolean)
    endfor;
    true -> boolean;
enddefine;


The next version uses recursion, in the functional style. People who
like this style do not use output local variables. The result of the
procedure is simply whatever is left on the stack, in this case true
or false.

define issubset(list1, list2);

    ;;; The empty list is a subset of every list.
    if list1 == [] then true

    ;;; otherwise if list2 is empty, then list1 cannot be a subset
    elseif list2 == [] then false

    ;;; see if tail of list1 is a subset of list2. If so, see if the
    ;;; head is a member. It could be done the other way round.
    elseif issubset(tl(list1), list2) and member(hd(list1), list2) then
        true
    else
        ;;; all conditions for being a subset failed, so
        false
    endif
enddefine;


Here is the same thing with an output local variable, so that someone
looking at the header can see what sort of result the procedure produces

define issubset(list1, list2) -> boolean;

    if list1 == [] then true

    elseif list2 == [] then false

    elseif issubset(tl(list1), list2) and member(hd(list1), list2) then
        true
    else
        false
    endif -> boolean

enddefine;


Write some test cases and check that the procedure works.


-- REDUNDANT ----------------------------------------------------------

;;; This procedure takes a list of items and returns a boolean result

define redundant(list) -> boolean;
    ;;; return true if the list is redundant, otherwise false

    lvars list, item;    ;;; pattern variables

    while list matches ! [?item ??list] do
        if member(item, list) then true -> boolean; return(); endif;
    endwhile;

    false -> boolean;
enddefine;

The line containing member could be changed to

        returnif( member(item, list) )(true -> boolean)

Using the matcher is not the most efficient way. Here is an answer that
does not use the matcher and is better programming style because it
is more efficient, and probably clearer.

define redundant(list) -> boolean;

    lvars sub;

    ;;; Use "for ... on ...do" to get successive tails.
    ;;; See HELP * FOR

    for sub on list do
        if member(hd(sub), tl(sub)) then
            true -> boolean;
            return()
        endif
    endfor;

    false -> boolean;
enddefine;

;;; Here is a recursive, functional style version,without output local

define redundant(list);
    ;;; an empty list is not redundant
    if list == [] then
        false

    ;;; if the first element is in the tail then it is
    elseif member(hd(list), tl(list)) then
        true

    ;;; or if the tail is redundant then it is
    elseif redundant(tl(list)) then
        true

    else
        ;;; all forms of redundancy ruled out
        false

    endif
enddefine;

-- EXISTS -------------------------------------------------------------

This procedure, defined in TEACH SETS2 takes a list and a predicate, and
returns true if at least one thing in the list satisfies the predicate,
otherwise it returns false.

It could also have been defined thus

define exists(list, pred) -> found;

    ;;; because pred is a local lvar, we have to insert the
    ;;; procedure itself, not the word "pred" as the restriction
    if list matches ! [== ?found: ^pred ==] then
        true -> found
    else
        false -> found
    endif
enddefine;


The next version avoids the need for "^" before pred, but is
not a good way to program, as the variable pred is not lexically
scoped, and could interact with something else.

define exists(list, pred) -> found;

    vars pred;  ;;; make pred dynamically scoped

    if list matches ! [== ?found: pred ==] then
        true -> found
    else
        false -> found
    endif
enddefine;



The next version uses a loop instead of the matcher, which is more
efficient. We also declare the input variable "pred" to be of
type procedure. That means that

(a) if you give exists a second argument that is not a procedure you
will get an error message, which is useful for finding bugs in your
programs, and

(b) exists will test when it starts that pred is a procedure, so that
the calls in the loop do not all need to involve the test. This makes
the program somewhat more efficient. If a variable is not declared to be
of type procedure, then whenever it is used in a procedure call pop-11
does a check at run time that it has a procedure value.
(See HELP EFFICIENCY if you want to know more.)

define exists(list, procedure pred) -> found;

    lvars item;

    for item in list do
        if pred(item) then true -> found; return() endif;
    endfor;

    false -> found;
enddefine;


;;; The next version uses "returnif" in this format
;;; returnif( <condition> )( <action> )
;;; Meaning if <condition> then <action>; return(); endif;

define exists(list, procedure pred) -> found;
    lvars item;

    for item in list do
        returnif(pred(item))(true -> found)
    endfor;

    false -> found;
enddefine;

Here is a version that returns the item found, or false. Usually
returning the item found is more useful than returning true.
See findone below.

define exists(list, procedure pred) -> found;
    lvars item;

    for item in list do
        returnif( pred(item) )( item -> found )
    endfor;

    false -> found;
enddefine;


This one uses "item" as the output local, saving a local variable.
In that case the return instruction can be simplified.

define exists(list, procedure pred) -> item;

    for item in list do
        returnif( pred(item) )
    endfor;

    false -> item;
enddefine;


Here is a recursive version, in the functional style

define exists(list, procedure pred);
    if list == [] then
        false
    elseif pred(hd(list)) then
        true
    else
        exists(tl(list), pred)
    endif
enddefine;

-- FINDONE ------------------------------------------------------------

This is essentially the same as exists, except for the result returned.

define findone(list, procedure pred) -> item;

    for item in list do
        ;;; the result returned will be item if pred(item) is true
        returnif( pred(item) )
    endfor;

    false -> item;

enddefine;

NOTE
    returnif( < expression > )

is equivalent to

    if < expression > then return() endif

See REF * SYNTAX/returnif  REF * SYNTAX/returnunless


Here is a recursive version in the functional style

define findone(list, procedure pred);
    if list == [] then false

    elseif pred(hd(list)) then hd(list)

    else findone(tl(list), pred)

    endif
enddefine;



-- ALL ----------------------------------------------------------------

define all(list, procedure pred) -> boolean;
    ;;; return true if all items in the list satisfy pred, otherwise
    ;;; false
    lvars item;
    for item in list do
        unless pred(item) then false -> boolean; return() endunless;
    endfor;
    true -> boolean;
enddefine;

Alternatively:

define all(list, pred) -> boolean;
    lvars item;
    for item in list do
        returnunless ( pred(item) )( false -> boolean)
    endfor;
    true -> boolean;
enddefine;


Another way to define this would use <> to join the procedure
pred to the procedure not, producing a new procedure which always
produces the opposite truth value to that produced by pred.

define all(list, pred) -> boolean;
    not( exists( list, pred <> not) )
enddefine;

That has the disadvantage that every time you run it it has to create
the procedure pred <> not, which will be used temporarily then
discarded, increasing the time spent doing garbage collection.
But it is a nice elegant solution.


-- HASODD HASEVEN ALLODD ALLEVEN --------------------------------------

This is defined here in the functional style. It might be better
to use output locals, e.g. "-> boolean"

define hasodd(list);
    exists(list, odd)
enddefine;

HASEVEN can be defined similarly.


Or, using partial application:

vars procedure(hasodd, haseven);
    exists(%odd%) -> hasodd;
    exists(%even%) -> haseven;

or, equivalently:

vars procedure(
    hasodd = exists(%odd%),
    haseven = exists(%even%)
);

or

define hasodd = exists(%odd%)
enddefine;

define haseven = exists(%even%)
enddefine;

hasodd([ 3 5 7 2 4 5 6 8]) =>
haseven([ 3 5 7 2 4 5 6 8]) =>
hasodd([ 2 4 6 8]) =>
haseven([ 3 5 7 5 ]) =>


Compare the result if exists is defined so as to return the object
found, instead of true, or if you use findone instead of exists.

Similarly, allodd and alleven can be defined using partial application;

vars procedure(
    allodd = all(%odd%),
    alleven = all(%even%)
);

or

define allodd = all(%odd%)
enddefine;

define alleven = all(%even%)
enddefine;


-- FINDALL ------------------------------------------------------------

A recursive version

define findall(list, procedure pred) -> newlist;
    ;;; return a list of all items in list that satisfy pred
    if  list == [] then
        [] -> newlist
    elseif  pred(hd(list)) then
        [^(hd(list)) ^^( findall(tl(list), pred) )] -> newlist
    else
        findall( tl(list), pred ) -> newlist
    endif
enddefine;

An iterative version using the matcher. Note that each time round the
loop the variable list has as its value a smaller sublist.

define findall(list, procedure pred) -> newlist;
    lvars item;
    [% while list matches ! [ == ?item: ^pred ??list] do item endwhile %]
        -> newlist;
enddefine;


A more efficient iterative version, possibly clearer too:

define findall(list, procedure pred) -> newlist;

    lvars item;

    [% for item in list do if pred(item) then item endif endfor%]
        -> newlist;
enddefine;


A recursive version in the functional style

define findall(list, pred) -> newlist;
    if list == [] then
        []
    elseif pred(hd(list)) then
        hd(list) :: findall(tl(list), pred)

    else
        findall(tl(list), pred)
    endif
        -> newlist;
enddefine;

/*
;;; some tests
    findall([], isword) =>
    ** []
    findall([a 1 b 2 c 3], isinteger) =>
    ** [1 2 3]
    findall([a 1 b 2 c 3], isword) =>
    ** [a b c]

*/


-- PRUNE --------------------------------------------------------------


define prune(list) -> result;
    ;;; Make a copy of the list which does not contain repeated items.

    lvars sub, item;

    [%
        ;;; use "on" so sub has successive tails as values
        for sub on list do
            hd(sub) -> item;
            unless member(item, tl(sub)) then item endunless
        endfor
    %] -> result;

enddefine;

A still more efficient version using the procedure dest, which, when
applied to a list returns both its head and its tail. See * dest

define prune(list) -> result;
    lvars item;

    [%
        until list == [] do
            dest(list) -> (item, list);
            unless member(item, list) then item endunless
        enduntil
    %] -> result;

enddefine;

Here is a recursive version in the functional style

define prune(list) -> result;
    if list == [] then
        []
    elseif member(hd(list), tl(list)) then
        prune(tl(list))
    else
        hd(list) :: prune(tl(list))
    endif -> result
enddefine;

/*
;;; test examples
prune([A B 1 2 C 2 1 B A])=>
** [C 2 1 B A]
rev(prune(rev([A B 1 2 C 2 1 B A]))) =>
** [A B 1 2 C]

*/


The above definitions of prune do not return items in the order
specified in the question, in which the first occurrence is kept
and subsequent ones removed.
For that you have to reverse the list before giving it to prune,
and then reverse the result. Why?

Here is a recursive version that produces the result specified in the
question, i.e. it does it in the right order. But it requires deleting
items from the tail of the list before running the recursive call.


define prune(list) -> result;
    if list == [] then
        []
    elseif member(hd(list), tl(list)) then
        hd(list) :: prune( delete(hd(list), tl(list)) )
    else
        hd(list) :: prune( tl(list) )
    endif -> result;
enddefine;

/*
;;; try these tests, tracing prune
prune([A B 1 2 C 2 1 B A])=>
rev(prune(rev([A B 1 2 C 2 1 B A]))) =>
*/

A disadvantage of this version is that the use of delete before the
recursive call of prune means that the rest of the list is traversed
TWICE, once to delete items equal to the head of the list, and then once
to prune the tail. And that is AFTER member has already traversed the
tail.

So if you care about efficiency it is better not to worry about creating
the pruned list in the right order. However, sometimes you need to
preserve the order of a list, e.g. when all items are stored in
alphabetical order in lists.

-- UNION --------------------------------------------------------------

This version is wasteful. Why?

define union(list1, list2) -> result;
    ;;; return a list containing all elements of list1 and list2 without
    ;;; any repeats
    prune( [^^list1 ^^list2] ) -> result;
enddefine;

Slightly more efficient perhaps:

define union (list1, list2) -> newlist;
    lvars item;
    [
        %
        for item in list1 do
            unless member(item, list2) then item endunless
        endfor
        %
        ^^list2
    ] -> newlist;

    ;;; optional extra
    ;;; sort(newlist) -> newlist;
enddefine;

If the union is to be alphabetically ordered, or numerically ordered,
end with

    sort(newlist) -> newlist

in the procedure. This will work only if the original list contains only
words and strings, or only numbers.


-- INTERSECTION -------------------------------------------------------

define intersection(list1, list2) -> newlist;
    ;;; return a list containing all items that occur in both lists.
    lvars item;

    [% for item in list1 do
        if member(item, list2) then item endif
    endfor %] -> newlist;

enddefine;

Note that in this version of intersection, items are put in newlist
in the order in which they were in list1. This may make sorting
unnecessary.

-- LARGER -------------------------------------------------------------

define setsize(list);
    ;;; If list may contain repreated elements use "setsize" to
    ;;; find the number of distinct items in it.
    ;;; This is wasteful because it first creates the pruned list.
    length(prune(list))
enddefine;

Here is a less wasteful version

define setsize(list) -> num;
    if list == [] then
        0
    elseif member(hd(list), tl(list)) then
        setsize(tl(list))
    else
        1 + setsize(tl(list))
    endif -> num
enddefine;

/*
;;; test it

    setsize([1 2 3 4 5]) =>
    ** 5
    setsize([5 1 4 2 3 4 5]) =>
    ** 5
    setsize([1 2 3 4 5 5 4 3 2 1]) =>
    ** 5

*/




define larger(list1, list2) -> boolean;
    if setsize(list1) > setsize(list2) then
        true
    else
        false
    endif -> boolean
enddefine;

or

define larger(list1, list2) -> boolean;
    setsize(list1) > setsize(list2) -> boolean
enddefine;


-- HOWMANY ------------------------------------------------------------

define howmany(list, procedure pred) -> total;
    ;;; return the number of items in list that satisfy pred

    lvars item;

    0 -> total;

    for item in list do
        if pred(item) then total + 1 -> total endif
    endfor

enddefine;

/*

howmany([1 a b 2 3 c 4], isword) =>
howmany([1 a 1.5 b 2 3 c 4], isnumber) =>

*/


-- MORE ---------------------------------------------------------------

define more(list1, pred1, list2, pred2);
    ;;; are there more elements in list1 satisfying pred1 than
    ;;; elements in list2 satisfying pred2?

    howmany(list1, pred1) > howmany(list2, pred2)

enddefine;

-- MOST ---------------------------------------------------------------

We can use <> to join two procedures to produce a new procedure. So if
pred is a predicate which returns true or false as its result, then
using 'pred <> not' we define a new procedure which returns true when
the old one was false and vice versa.

define most(list,pred);
    more(list, pred, list, pred <> not)
enddefine;

;;; This version is more efficient. Why?

define most(list,pred);
    ;;; more than half the elements of the list satisfy pred
    2 * howmany(list, pred) > length(list)
enddefine;


/*

most([1 a b 2 3 c 4], isword) =>
most([1 a b 2 3 c 4], isinteger) =>
most([1 a 1.5 b 2 3 c 4], isword) =>
most([1 a 1.5 b 2 3 c 4], isnumber) =>

*/

-- REMOVEALL ----------------------------------------------------------

define removeall(list, pred);
    ;;; return a list of items in list that do not satisfy pred
    findall(list, pred <> not)
enddefine;

or

define removeall(list, procedure pred) -> newlist;
    lvars item;
    [%for item in list do unless pred(item) then item endunless endfor%]
        -> newlist;
enddefine;

/*
removeall([1 a b 2 3 c 4], isword) =>
** [1 2 3 4]
removeall([1 a b 2 3 c 4], isinteger) =>
** [a b c]
removeall([1 a 1.5 b 2 3 c 4], isword) =>
** [1 1.5 2 3 4]
removeall([1 a 1.5 b 2 3 c 4], isnumber) =>
** [a b c]
*/

-- SUBTRACT -----------------------------------------------------------

First version uses partial application, i.e. it partially applies
member to listb, to get the second argument for removall.

define subtract(lista, listb) -> newlist;
    ;;; return a list of elements of lista that are not in listb
    ;;; Use partial application for the second argument of removeall
    removeall(lista, member(%listb%) ) -> newlist
enddefine;


The next version is more efficient. Why?

define subtract(lista, listb) -> newlist;
    ;;; return a list of elements of lista that are not in listb

    lvars item;

    [% for item in lista do
        unless member(item, listb) then item endunless
       endfor %] -> newlist;
enddefine;

/*

subtract([1 2 3 4 5 6], [2 4 6]) =>
** [1 3 5]

subtract([1 2 3 4 5 6], [1 3 5]) =>
** [2 4 6]


*/

-- OVERLAPS EXCLUDES --------------------------------------------------

define overlaps(list1, list2) -> result;
    lvars item;
    for item in list1 do
        if member(item, list2) then true -> result; return() endif
    endfor;
    false -> result
enddefine;

define excludes(list1, list2);
    not(overlaps(list1,list2))
enddefine;

-- SUBCULTURE ---------------------------------------------------------------

There are VERY MANY ways of doing this. Several different solutions
are provided below.

subculture is given a list of lists and returns a new list of lists
containing the maximal connected subsets from the original list.
I.e. if two lists have any overlapping elements it replaces them
with their union, so the final list of lists contains no lists that
overlap each other.

In general the easiest way to define such a procedure is to deal with
the case where the intput list is empty, and use recursion to deal with
other cases. I.e. if you want to find all the maximal subcultures
in LIST first get the result of finding them for the tail of LIST,
then do what you need to do with the head of LIST.

In this case see if the head of the list overlaps with any lists in the
subculture, and if so extract them and merge them with each other and
the head. The problem as stated in the teach file assumes that the input
list contains only two element lists. So we initially produce a solution
based on that assumption, then see how to generalise it to merge lists
with any number of elements.


-- . subculture version 1

Assume there is a procedure that takes the result of the
recursive call of subculture, and then adds one more two element list.

Call it add_first(first, lists), defined below. We can then use it to
define a recursive version of subculture, thus:

vars procedure add_first; ;;; defined below.

define subculture(lists) -> result;
    ;;; lists is a list of two element lists. The result must satisfy
    ;;; the requirements of subculture.

    ;;; First deal with the trivial case where there are no lists
    if lists == [] then
        ;;; no subcultures in an empty list
        [] -> result;
    else
        ;;; There are one or more pairs in lists.
        ;;; Find all the subcultures in the tail of lists, then
        ;;; add in the head. That's all!
        add_first( hd(lists), subculture(tl(lists)) ) -> result
    endif;
enddefine;


;;;  Now define add_first. It uses union, defined above.

define add_first(first, lists) -> newlists;
    ;;; first is a two element list that came from the head of the
    ;;; list given to subculture. lists is the result of applying
    ;;; subculture to the tail. So lists already has been arranged
    ;;; into a list of lists that are "maximal" groups, i.e. they
    ;;; do not overlap.

    ;;; If any subculture in lists overlaps with first, merge them.
    ;;; Since first contains only two elements, and no elements of lists
    ;;; overlap (by assumption), there cannot be more than two
    ;;; things to merge.

    ;;; We grow a new subculture, starting from first, and merge it
    ;;; with anything in lists that contains an element of first.
    lvars newculture;

    first -> newculture;

    ;;; Make a list of all the things in lists that don't contain
    ;;; either item in the first, and add those that do to newculture

    lvars subcult, item1 = first(1), item2 =first(2);

    [%  for subcult in lists do
            if member(item1, subcult) or member(item2, subcult) then
                ;;; the first and subcult overlap, so
                ;;; merge the subcult with the newculture
                 union(newculture, subcult) -> newculture
            else
                ;;; keep the non-overlapping subculture as it is
                subcult
            endif
        endfor
    %] -> newlists;

    ;;; now put the newculture at the front of newlists.

    [^ newculture ^^newlists] -> newlists;

enddefine;

-- . Test cases for subculture

/*
;;; test it, with and without tracing subculture.

subculture([]) =>
** []

subculture([[a b] [b c] [d e] [e f]]) =>
** [[a b c] [d e f]]

subculture([[a e] [b f] [c g] [d g]]) =>
** [[a e] [b f] [c d g]]

subculture([[a f] [g i] [h b] [f e] [c h] [j d] [g j] [b h] [d i]]) ==>
** [[a f e] [g j d i] [c b h]]

subculture([[ a b] [a d ] [e f] [d g] [ p q f]]) =>
** [[b a d g] [e p q f]]

;;; Notice that this version does not work when the input includes sets
;;; with more than two elements. Why?

subculture([[a b f ] [c d e] [e b ] [f g] [ a h]])=>
** [[f e b a h] [c d e] [f g]]

;;; It did not notice that e and f each occurred in two of the output
;;;     lists. The result should have contained a single big list.

;;; What change is needed to make it notice this? (A very simple
;;; change will fix it. Look at where the program assumed implicitly
;;; that only pairs were involved.)
*/

-- . subculture version 2

The previous version of add_first assumed that first had only two
elements. Thus to check whether an existing subgroup produced by the
recursive call had to be merged with the new one or not it sufficed to
use this test:
            if member(item1, subcult) or member(item2, subcult) then

However if first has more than two elements, then instead of
listing them and testing them separately we can use the procedure
overlaps defined above and say
            if overlaps(first, subcult) then

overlaps could be defined thus:

define overlaps(list1, list2) -> boolean;
    lvars item;
    for item in list1 do
        returnif( member(item, list2) )( true -> boolean )
    endfor;
    false -> boolean
enddefine;


;;; Now modified version of add_first
define add_first(first, lists) -> newlists;

    ;;; We grow a new subculture, starting from first, and merge it
    ;;; with anything in lists that overlaps with first. Others
    ;;; are kept as they are

    ;;; Make a list of all the things in lists that don't contain
    ;;; either item in the first, and add those that do to first

    lvars subcult, item1 = first(1), item2 =first(2);

    [%  for subcult in lists do
            if overlaps(first, subcult) then
                 union(first, subcult) -> first
            else
                subcult
            endif
        endfor
    %] -> newlists;

    ;;; now put the first at the front of newlists.

    [^ first ^^newlists] -> newlists;

enddefine;

/*
;;; test that subculture now works with three element lists.

subculture([[a b f ] [c d e] [e b ] [f g] [ a h]])=>
** [[g f d c e b a h]]

*/

-- . subculture version 4

This version is nearly like the above but does not use a separate
add_first procedure. Instead the code is in a loop in subculture.

It also makes use of the procedure "overlaps" defined above

define subculture(lists) -> result;
    lvars first, sub, temp;
    if lists == [] then
        [] -> result;
    else
        ;;; Do the recursive call
        subculture(tl(lists)) -> temp;

        ;;; form a first subculture using the head
        hd(lists) -> first;
        ;;; See if any of the subcultures in temp need to be
        ;;; merged with the items in first.
        [% for sub in temp do
            if overlaps(first, sub) then
                ;;; subculture from tail of list must be merged with first one
                union(first, sub) -> first;
            else
                ;;; use the original subculture from tail of list
                sub
            endif
          endfor
        %] -> result;
        ;;; Now add the subculture to the result.
        [^first ^^result] -> result;
    endif;
enddefine;
/*
;;; test it on the problem that defeated the previous version
subculture([[a b f ] [c d e] [e b ] [f g] [ a h]])=>
** [[g f d c e b a h]]

;;; It works.
;;; You should also test it on the other cases

*/

-- . subculture version 5

;;; Another tempting possible definition of subculture
;;; Start by trying to merge the first item with everything that
;;; can be merged. Then use everything left over to form new
;;; subcultures, recursively. This has a bug. Why?

define subculture(lists) -> result;
    lvars  item, sub, rest;
    if lists == [] then
        [] -> result
    else
        ;;; get the first element and see which others can be merged with it
        ;;; to form a subculture
        hd(lists) -> sub;
        [] -> rest;
        [% for item in tl(lists) do
              if overlaps(sub, item) then
                  union(sub, item) -> sub;    ;;; enlarge the subculture
              else
                  item                ;;; build a list of elements which
                  ;;; can't be merged with sub
              endif;
           endfor %] -> rest;

        ;;; now run subculture on the list of groups that could not
        ;;; be linked to the first element, and return that with the
        ;;; enlarged first group
        [^sub ^^(subculture(rest))] -> result;
    endif;
enddefine;

/*
;;; test it
subculture([[ a b] [a d ] [e f] [d g] [ p q f]]) =>
** [[a b d g] [e p q f]]

;;; That's OK, but here's an example of the bug.
subculture([[a b ] [c d] [e d] [f g] [f a ]])=>
** [[b f a] [c e d] [f g]]

;;; Why has it not merged the first two lists?
*/


-- QUESTION 24 --------------------------------------------------------

This is potentially quite a large mini project, though it is not fully
specified by the question.

An example approach to this can be found in TEACH INDUCE_RULES.P

But it does not solve all the problems.


--- $poplocal/local/teach/sets2.ans
--- Copyright University of Birmingham 1996. All rights reserved. ------