/*  BOARDGEN.PL  */
 
 
/*
This program defines the predicate
    file_to_board( In, Out )
which reads the board definition file In and converts it to Prolog clauses
in Out.
 
The idea is that the board, as the student sees it, is represented as
in Supplement 4:
    square( N, X, Y )
    joins( Square1, Square2 )
    in( Square, LoopName )
    loop( LoopName )
    building( Square, Name )
    sells_fuel( Name, Price )
    buys( ShopName, Good, Price )
    sells( ShopName, Good, Price )
 
Being tedious to type all these, it's easier to generate them
automatically from definitions of the following form:
 
    BoardFile -->
        Loop | Line2 | Line1
 
    (A board definition file is a sequence of terms, each defining
    either a closed region, a line with specified start and end labels,
    or a line with specified start label.)
 
    Loop -->
        loop( LoopName, LoopSegment ).                 
 
    (Defines a set of points forming a closed curve, whose start point
    is defined by the co-ordinate pair which is LoopSegment's first
    element, and the rest of which is defined by the other elements.
    The final point defined by the loop should be the same as the first
    point. For the game as described in Supplement 4 to work, you
    should define loops in a clockwise direction, so that predicate
    "clockwise" works.)
 
    Line2 -->
        line( LabelName1, Segment, LabelName2 ).
 
    (Defines a line starting at the already-defined label LabelName1,
    and ending at the already-defined label LabelName2. An error will
    be reported if the line as defined by Segment does not end at the
    second label. Note that Segment does not contain co-ordinates: the
    start point is defined by LabelName1.)
 
    Line1 -->
        line( LabelName, Segment ).
 
    (Defines a line starting at the already-defined label LabelName1.)
 
    LabelName -->
        any atom
 
    LoopName -->
        any atom
 
    LoopSegment -->
        a list whose first element must be a CoOrdinate, and whose
        other elements must be SegmentParts
 
    Segment -->
        a list whose elements must be SegmentParts
 
    CoOrdinate -->
        ( Integer, Integer )
 
    (The two integers give the X and Y locations.)
 
    SegmentPart -->
        Building |
        Move |
        Label
 
    Building -->
        Name / f / SellPrice
        Name / ShopType / buy / BuyPrice
        Name / ShopType / sell / SellPrice
 
    (Defines the shops and fuel stations. Name is the name of a shop or
    fuel station, Buy and SellPrice are integers or reals.)
 
    Move -->
        SimpleMove | CompoundMove
 
    SimpleMove -->
        right | left | up | down |
        up_right | up_left | down_right | down_left
 
    (Defines a move of 1 X and/or Y unit in the specified direction.)
 
    CompoundMove -->
        a term whose functor is any SimpleMove, and which has one
        argument, a positive integer
 
    (Defines a move of N X and/or Y units in the specified direction,
    e.g. up_right(3) moves from X,Y to X+3,Y+3.)
 
    Label -->
        LabelName:
 
    (i.e. a term :(LabelName). : is defined as an fx operator. When the
    board generator encounters a label it defines it to have the
    co-ordinate of the current square. This can then be used
    subsequently for connecting different lines and loops.)
 
Other terms are copied verbatim from the definition file.
 
For an example, see BOARD.DAT.
*/
 
 
/*
For the purpose of the code below, see MASTER.PL. Some of it can be
removed if not using Poplog.
*/
 
:- library(macro).
:- killmac("prolog").
:- killmac("teach").
:- killmac("ref").
:- killmac("help").
:- killmac("lib").
 
:- quietspy(on).
sp :- (spy), (nospy prolog_expand_term),
    (nospy prolog_user_goal),
    (nospy prolog_expand_goal).
 
:- reconsult( '[popx.book.disc.source]lib.pl' ).
 
:- lib( chars ).
:- lib( control ).
:- lib( findall ).
:- lib( useful ).
:- lib( lists ).
:- lib( output ).
:- lib( output_english ).
 
 
/*
Main read-and-process loop.
---------------------------
*/
 
 
/*  file_to_board( In+, Out+ ):
        In and Out are input and output file names. Convert the board
        definition in In to a corresponding set of clauses in Out. Does
        not check for file errors.
*/
file_to_board( Input, Output ) :-
    seeing( CIS ),
    telling( COS ),
    see( Input ), seen,
    /*  Ensure that if file was open, it's re-opened at the start. */
    see( Input ),
    tell( Output ),
    write( '/*  ' ), write( Output ), write( '  */' ), nl,
    initialise,
    file_to_board,
    seen, see( CIS ),
    told, tell( COS ).
 
 
file_to_board :-
    while(
           (read( X ), X\==end_of_file),
           process( X )
         ),
    board_to_cos.
 
 
/*  process( Term+ ):
        Process one term read from a board definition file, asserting
        information describing what is to be output.
*/
process( loop( Name, Def ) ) :-
    !,
    loop( Name, Def ).
 
process( line( Label1, Def, Label2 ) ) :-
    !,
    line( Label1, Def, Label2 ).
 
process( line( Label1, Def ) ) :-
    !,
    line( Label1, Def ).
 
process( Other ) :-
    !,
    /*  Assume it's a clause, and store for later output.  */
    assert( '$term'(Other) ).                  
 
 
 
/*
Board definition operators.
---------------------------
 
The terms up_right, up_left, down_right and down_left were originally
going to be up/, up\, down\ and down/, using \ and / as operators. This
is both shorter and more suggestive. However, if / is declared as a
unary xf operator, Poplog cannot parse terms like "down/" which contain
it. This should be unambiguous even though / is also a binary operator,
but Poplog doesn't seem to be up to it.
*/
 
 
:- op( 10, xf, : ).
 
 
/*
Board construction.
-------------------
 
This is a process of running over the segment lists, updating the
coordinate of the current square, and making assertions describing it.
It would be more satisfying to purists if this were done declaratively,
transforming a segment list into a list of square definitions and
outputting that directly. However, this is faster to write. If purists
want the declarative form, they should provide libraries for handling
fast updateable structures.
 
Meaning of assertions:
 
    '$loop'(LoopName):
        There is a loop called LoopName.
 
    '$label'(LabelName,X,Y):
        LabelName labels square (X,Y).
 
    '$square'(N,X,Y):
        N is the square number for (X,Y).
 
    '$square'(N):
        N is the number of the last square defined. Initially 0. At the
        end of the game, gives the total number of squares.
 
    '$joins'(X1,Y1,X2,Y2):
        Square (X1,Y1) is directly joined to (X2,Y2).
 
    '$in'(LoopName,X,Y):
        Square (X,Y) is in loop LoopName.
 
    '$contents'(Building,X,Y):
        Building is in square (X,Y).
 
    '$fuel'(Building,Price):
        Building is a fuel station selling at Price.
 
    '$shop'(Building,Type,buy,Price):
    '$shop'(Building,Type,sell,Price):
        Building is a shop of type Type buying or selling at Price.
*/
 
 
/*  initialise:
        Clear all assertions about a board. Call this before starting a
        new one.
*/
initialise :-
    retractall( '$term'(_) ),
    retractall( '$loop'(_) ),
    retractall( '$label'(_,_,_) ),
    retractall( '$square'(_,_,_) ),
    retractall( '$square'(_) ),
    retractall( '$joins'(_,_,_,_) ),
    retractall( '$in'(_,_,_) ),
    retractall( '$contents'(_,_,_) ),
    retractall( '$fuel'(_,_) ),
    retractall( '$shop'(_,_,_,_) ),
    assert( '$square'(0) ).
 
 
/*  loop( Name+, Def+ ):
        Process a loop definition.
*/
loop( Name, Def ) :-
    '$loop'( Name ),
    !,
    err( 'loop: loop declared twice', Name ).
 
loop( Name, Def ) :-
    assert( '$loop'(Name) ),
    loop_1( Name, Def ).
 
 
loop_1( Name, Def ) :-
    (
        Def = [ (X,Y) | RestDef ]
    ->
        segment( Name, RestDef, X, Y, new, loop(X,Y) )
    ;
        err( 'loop_1: definition must start with co-ordinates.', Def )
    ).
 
 
/*  line( Label1+, Def+, Label2+ ) :-
        Process a line definition.
*/
line( Label1, Def, Label2 ) :-
    '$label'( Label1, X, Y ),
    !,
    line_1( X, Y, Def, Label1, Label2 ).
 
line( Label1, Def, Label2 ) :-
    err( 'line: start label not defined.', [Def] ).
 
 
line_1( X, Y, Def, Label1, Label2 ) :-
    '$label'( Label2, XN, YN ),
    !,
    segment( line(Label1,Label2), Def, X, Y, new, line_end(XN,YN) ).
 
line_1( X, Y, Def, Label1, Label2 ) :-
    err( 'line_1: end label not defined.', [Def,Label2] ).
 
 
/*  line( Label1+, Def+ ) :-
        Process a line definition.
*/
line( Label1, Def ) :-
    '$label'( Label1, X, Y ),
    !,
    segment( line(Label1), Def, X, Y, new, open ).
 
line( Label1, Def ) :-
    err( 'line: start label not defined.', [Def] ).
 
 
/*  segment( Name+, Def+, X+, Y+, State+, IfClosed+ ):
        Process a segment.
*/
segment( Name, Def, X, Y, new, IfClosed ) :-
    (
        '$square'(_,X,Y)
    ->
        true
    ;
        '$square'(S),
        retractall( '$square'(_) ),
        SNew is S + 1,
        assert( '$square'(SNew,X,Y) ),
        (
            IfClosed = loop(_,_)
        ->
            assert( '$in'(Name,X,Y) )
        ;
            true
        ),
        asserta( '$square'(SNew) )
    ),
    segment( Name, Def, X, Y, old, IfClosed ).
 
segment( Name, Def, X, Y, from(X0,Y0), IfClosed ) :-
    assert( '$joins'(X0,Y0,X,Y) ),
    segment( Name, Def, X, Y, new, IfClosed ).
 
segment( Name, [], X, Y, old, loop(X,Y) ) :-
    !.
 
segment( Name, [], X, Y, old, loop(X0,Y0) ) :-
    !,
    err( 'segment: loop does not end where it started.', [Name,X,Y,X0,Y0] ).
 
segment( Name, [], X, Y, old, line_end(X,Y) ) :-
    !.
 
segment( Name, [], X, Y, old, line_end(XN,YN) ) :-
    !,
    err( 'segment: line does not end where it should.', [Name,X,Y,XN,YN] ).
 
segment( Name, [], X, Y, old, open ) :-
    !.
 
segment( Name, [Label:|RestDef], X, Y, old, IfClosed ) :-
    '$label'( Label, _, _ ),
    !,
    err( 'segment: label already seen.', [Name,Label] ).
 
segment( Name, [Label:|RestDef], X, Y, old, IfClosed ) :-
    asserta( '$label'(Label,X,Y) ),
    segment( Name, RestDef, X, Y, old, IfClosed ).
 
segment( Name, [Contents|RestDef], X, Y, old, IfClosed ) :-
    is_contents( Contents, _ ),
    '$contents'( _, X, Y ),
    !,
    err( 'segment: square already filled.', [Name,Contents,X,Y] ).
 
segment( Name, [Contents|RestDef], X, Y, old, IfClosed ) :-
    is_contents( Contents, BuildingName ),
    '$contents'( BuildingName, X0, Y0 ),
    !,
    err( 'segment: name already used.', [Name,Contents,X,Y,X0,Y0] ).
 
segment( Name, [Contents|RestDef], X, Y, old, IfClosed ) :-
    is_contents( Contents, BuildingName ),
    !,
    assert( '$contents'( BuildingName, X, Y ) ),
    do_contents( Contents ),
    segment( Name, RestDef, X, Y, old, IfClosed ).
 
segment( Name, [Move|RestDef], X, Y, old, IfClosed ) :-
    is_move( Move ),
    !,
    move( Move, X, Y, X1, Y1 ),
    segment( Name, RestDef, X1, Y1, from(X,Y), IfClosed ).
 
segment( Name, [Move|RestDef], X, Y, old, IfClosed ) :-
    is_compound_move( Move, First, Rest ),
    !,
    move( First, X, Y, X1, Y1 ),
    segment( Name, [Rest|RestDef], X1, Y1, from(X,Y), IfClosed ).
 
segment( Name, [none|RestDef], X, Y, old, IfClosed ) :-
    !,
    segment( Name, RestDef, X, Y, old, IfClosed ).
 
segment( Name, [Thing|RestDef], X, Y, old, IfClosed ) :-
    err( 'segment: unrecognised element.', [Name,Thing,X,Y] ).
 
 
/*  is_contents( C+, Name- ):
        C is something that defines the contents of a square.
        Name is instantiated to its name.
 
        Note: the clauses of is_contents and do_contents must be in this
        order so that _/_/_/_ is not treated as _/_/_ .
*/
is_contents( Name/_/_/_, Name ) :- !.
is_contents( Name/_/_, Name ).
 
 
/*  do_contents( C+ ):
        Check C and assert if it's OK.
*/
do_contents( Name/ST/BS/Price ) :-
    is_shop_type( ST, Full ),
    ( BS = buy ; BS = sell ),
    numeric( Price ),
    !,
    do_shop( Name, Full, BS, Price ).
 
do_contents( Name/ST/BS/Price ) :-
    !,
    err( 'do_contents: illegal _/_/_/_', [Name/ST/BS/Price] ).
 
do_contents( Name/f/SellPrice ) :-
    numeric( SellPrice ),
    !,
    asserta( '$fuel'(Name,SellPrice) ).
 
do_contents( Name/BS/SellPrice ) :-
    !,
    err( 'do_contents: illegal _/_/_', [Name/BS/SellPrice] ).
 
 
do_shop( Name, ST, BS, Price ) :-
    asserta( '$shop'(Name,ST,BS,Price) ).
 
 
/*  is_shop_type( T+, Full- ):
        T is the abbreviation used for a shop type in the board
        definition. Full is the full name.
*/
is_shop_type( c, coal ).
is_shop_type( d, diamonds ).
is_shop_type( g, glasses ).
is_shop_type( p, peaches ).
is_shop_type( tv, televisions ).
 
 
/*  is_move( M+ ):
        M is a (non-compound) move.
*/
is_move( right ).
is_move( left ).
is_move( up ).
is_move( down ).
is_move( down_right ).
is_move( down_left ).
is_move( up_right ).
is_move( up_left ).
 
 
/*  is_compund_move( M+, First-, Rest- ):
        M is a compound move.
        First is the first one-unit component; Rest is the rest.
        Rest is expressed as 'none' or a non-compound move if possible.
*/
is_compound_move( Move, Dir, Rest ) :-
    functor( Move, Dir, 1 ),
    arg( 1, Move, Steps ),
    is_move( Dir ),
    RestSteps is Steps - 1,
    (
        RestSteps = 1
    ->
        Rest = Dir
    ;
        RestSteps = 0
    ->
        Rest = none
    ;
        functor( Rest, Dir, 1 ),
        arg( 1, Rest, RestSteps )
    ).
 
 
/*  move( Dir+, X+, Y+, X_-, Y_- ):
        Dir is one of { right, left, up, down, up_right, up_left,
        down_right, down_left }.
        X_ and Y_ are the result of moving by one in the specified
        X and/or Y directions.
*/
move( right, X, Y, X_, Y ) :-
    !,
    X_ is X + 1.
 
move( left, X, Y, X_, Y ) :-
    !,
    X_ is X - 1.
 
move( up, X, Y, X, Y_ ) :-
    !,
    Y_ is Y + 1.
 
move( down, X, Y, X, Y_ ) :-
    !,
    Y_ is Y - 1.
 
move( down_right, X, Y, X__, Y__ ) :-
    !,
    move( down, X, Y, X_, Y_ ),
    move( right, X_, Y_, X__, Y__ ).
 
move( up_right, X, Y, X__, Y__ ) :-
    !,
    move( up, X, Y, X_, Y_ ),
    move( right, X_, Y_, X__, Y__ ).
 
move( down_left, X, Y, X__, Y__ ) :-
    !,
    move( down, X, Y, X_, Y_ ),
    move( left, X_, Y_, X__, Y__ ).
 
move( up_left, X, Y, X__, Y__ ) :-
    !,
    move( up, X, Y, X_, Y_ ),
    move( left, X_, Y_, X__, Y__ ).
 
 
/*
Writing out the board.
----------------------
*/
 
 
board_to_cos :-
    write_squares,
    write_joins,
    write_loops,
    write_buildings,
    write_other_terms.
 
 
write_squares :-
    forall(
            '$square'( N, X, Y )
          ,
            write_fact( square(N,X,Y) )
          ),
    nl,
    forall(
            (
            '$square'( N, X, Y ),
            '$contents'( C, X, Y )
            )
          ,
            write_fact( building(N,C) )
          ),
    nl.
 
 
write_joins :-
    forall(
            '$joins'(X,Y,X1,Y1)
          ,
            (
            assertion( '$square'(N,X,Y) ),
            assertion( '$square'(N1,X1,Y1) ),
            write_fact( joins(N,N1) )
            )
          ),
    nl.
 
 
write_loops :-
    forall(
            '$in'(Name,X,Y)
          ,
            (
            assertion( '$square'(N,X,Y) ),
            write_fact( in(N,Name) )
            )
          ),
    nl,
    forall(
            '$loop'(Name)
          ,
            write_fact( loop(Name) )
          ),
    nl.
 
 
write_buildings :-
    forall(
            '$fuel'(Name,SellPrice)
          ,
            write_fact( sells_fuel(Name,SellPrice) )
          ),
    nl,
    forall(
            '$shop'(Name,Type,buy,Price)
          ,
            write_fact( buys(Name,Type,Price) )
          ),
    nl,
    forall(
            '$shop'(Name,Type,sell,Price)
          ,
            write_fact( sells(Name,Type,Price) )
          ),
    nl.
 
 
write_other_terms :-
    forall(
            '$term'(Term)
          ,
            write_fact( Term )
          ),
    nl.
 
 
write_fact( F ) :-
    writeq( F ), write('.'), nl.
 
 
/*
Error reporting.
----------------
 
We don't name the predicate "error" because that's a Poplog system
predicate. The code is adapted from BUG.PL.
*/
 
 
/*  err( X+ ):
        Give error concerning message X. Intended for use like bug(X)
        but reports a user error, not a program bug.
*/
err( X ) :-
    err_1( '*** ERROR detected ***',
           X, '', ''
         ).
 
 
/*  err( X+, Culprit+ ):
        Give error concerning message X and culprit Y. Intended for use
        like bug(X,Culprit) but reports a user error, not a program bug.
*/
err( X, Culprit ) :-
    err_1( '*** ERROR detected ***',
           X, '\nCulprit(s): ', Culprit
         ).
 
 
/*  err_1( Type+, X1+, X2+, X3- ):
        Utility for writing bits of messages. The COS is assumed to be
        where you want the error report to go.
*/
err_1( Type, X1, X2, X3 ) :-
    tell( user ),
    write( Type ), nl,
    write(X1), write(X2), write(X3), nl,
    abort.
