Poniższe polecenie kompiluje program w Haskellu, a nastepnie wyświetla jego wydajność:
ghc -prof -auto-all --make zad.hs -o zad && cat input | ./zad +RTS -p -RTS && cat zad.prof
/*
* Usage:
* Format: M = [ (n1,v1), ..., (nn, vn) ]
* n - count (number)
* v - amount (value)
* Coin counts may not be negative
*
* ?- payment(123, [(10,1),(10,2),(10,5),(10,10)], X).
* ?- payment(123, [(10,1),(10,2),(10,5),(10,10)], [(10,1),(9,2),(9,5),(5,10)]).
*/
% We can pay 0 with an empty list of coins.
payment(0, _, []) :-
!. % nothing else we can do
% 0 coins of some amount.
payment(Amount, [(0,_)|Avail], Result) :-
!, % nothing more we can do
payment(Amount, Avail, Result). % dispose of them
% try paying with Num coins of type Coin
payment(Amount, [(Num,Coin)|Avail], [(Num,Coin)|Result]) :-
Amount > 0,
NAmount is Amount - Num * Coin,
payment(NAmount, Avail, Result).
% decrease the Num of coins of type Coin by one
payment(Amount, [(Num,Coin)|Avail], Result) :-
Amount > 0,
NNum is Num - 1, % the second predicate compares NNum against 0
payment(Amount, [(NNum,Coin)|Avail], Result).
/*
* Usage:
* ?- queens(5,X).
*/
% Check the newly added element for conflict with existing ones
check_prev([], _, _, _) :- !.
check_prev([Wj|List], J, I, Wi) :-
Wj =\= Wi,
Wj - Wi =\= I-J,
Wj - Wi =\= J-I,
Jn is J + 1,
check_prev(List, Jn, I, Wi).
% Gnu Prolog lacks the "between" builtin predicate.
% Assigns Nextnum a number from range Curnum..Maxnum inclusive
% Return the number unchanged
assignnum(Curnum, Maxnum, Curnum) :-
Curnum =< Maxnum. % If not out of bounds
% Increment the number
assignnum(Curnum, Maxnum, Nextnum) :-
Curnum =< Maxnum, % If not out of bounds
Nnum is Curnum + 1,
assignnum(Nnum, Maxnum, Nextnum).
% A wrapper is needed
queens(N,L) :- queens(0,N,[],L, N).
% Arguments are as follows: Number_of_existing_elements, Max_elements, Accumulator, Result, Position_of_the_new_element
% Enough elements have been generated
queens(Height, Height, L, L, _) :- !.
% Add a new element
queens(Width, Height, Acc, L, Last) :-
NewWidth is Width + 1,
assignnum(1, Height, Num), % Assign Num a value from 1 to Height inclusive
% Gprolog appears to lack the between predicate
NewLast is Last - 1,
check_prev(Acc, Last, NewLast, Num), % Check Num against previous elements
queens(NewWidth, Height, [Num|Acc], L, NewLast). % Check successiful, continue
/*
* Usage:
* Minimum valid board size is 1.
* Board sizes 2, 3, 4 produce no valid knight paths.
*
* ?- knight_path(5, X).
*/
% Available moves, out-of-bounds checks reduced to a minimum
nextmove((FromX, FromY), (ToX, ToY), Max) :- ToX is FromX+1, ToX =< Max, ToY is FromY+2, ToY =< Max.
nextmove((FromX, FromY), (ToX, ToY), Max) :- ToX is FromX+2, ToX =< Max, ToY is FromY+1, ToY =< Max.
nextmove((FromX, FromY), (ToX, ToY), Max) :- ToX is FromX+2, ToX =< Max, ToY is FromY-1, ToY > 0.
nextmove((FromX, FromY), (ToX, ToY), Max) :- ToX is FromX+1, ToX =< Max, ToY is FromY-2, ToY > 0.
nextmove((FromX, FromY), (ToX, ToY), _Mx) :- ToX is FromX-1, ToX > 0, ToY is FromY-2, ToY > 0.
nextmove((FromX, FromY), (ToX, ToY), _Mx) :- ToX is FromX-2, ToX > 0, ToY is FromY-1, ToY > 0.
nextmove((FromX, FromY), (ToX, ToY), Max) :- ToX is FromX-2, ToX > 0, ToY is FromY+1, ToY =< Max.
nextmove((FromX, FromY), (ToX, ToY), Max) :- ToX is FromX-1, ToX > 0, ToY is FromY+2, ToY =< Max.
% A wrapper is required
knight_path(Max, Path) :-
Moves is Max*Max,
knight_path(Max, Moves, [(1,1)], Path).
% Arguments are as follow: Map_width, Total_number_of_moves, History_of_moves/Accumulator, Result
% Max*Max moves done
knight_path(_Max, 1, Path, Path) :-
!.
knight_path(Max, Moveno, [(X,Y)|T], Path) :-
nextmove((X,Y),(Xn,Yn),Max), % get next potential move
\+ memberchk((Xn,Yn), T), % if not already done
NMoveno is Moveno - 1,
knight_path(Max, NMoveno, [(Xn,Yn),(X,Y)|T], Path). % perform the move
/*
* Usage:
* ?- solve(4, 6, 6, [(4,4),(-1,3),(-6,2),(4,2),(-3,1),(1,1),(4,0),(-5,-1),(-1,-1),(1,-1),(6,-2),(1,-3),(-3,-3)], W).
*/
% Main predicate
solve(MapSize, NoOfIslands, IslandSize, BlackenedIslands, Result ) :-
NumOfHex is (MapSize*2+1)+2*((MapSize*2+(MapSize+1))*MapSize//2), % Map size in hexagons
NumToBlacken is NumOfHex - IslandSize*NoOfIslands, % How many hexagons to blacken
generate_map( MapSize, Map ), % List of available hexagons
set_diff( Map, BlackenedIslands, NMap ), % Remove blackened islands
dosolve( MapSize, NMap, NumToBlacken, IslandSize, NoOfIslands, [], BlackenedIslands, Result ).
% Zero more islands to build, end.
dosolve( _MapSize, Map, NumToBlacken, _IslandSize, 0, _Island, BlackenedIslands, Result ) :-
!, % This is the only valid predicate
append(Map, BlackenedIslands, Result), % Blacken what is left of the map
length(Result, RLen),
RLen = NumToBlacken. % Check if the length of black hexagons is correct
% Island is empty, add to the island
dosolve( MapSize, [Elem|Map], NumToBlacken, IslandSize, NoOfIslands, [], BlackenedIslands, Result ) :-
dosolve( MapSize, Map, NumToBlacken, IslandSize, NoOfIslands, [Elem], BlackenedIslands, Result ).
% Island is empty, add to blacked
dosolve( MapSize, [Elem|Map], NumToBlacken, IslandSize, NoOfIslands, [], BlackenedIslands, Result ) :-
!, % No more empty-island predicates
NBlackenedIslands = [Elem|BlackenedIslands],
length(NBlackenedIslands, NBLen),
NBLen =< NumToBlacken, % Check if the length of black hexagons is correct
dosolve( MapSize, Map, NumToBlacken, IslandSize, NoOfIslands, [], NBlackenedIslands, Result ).
% Island is full
dosolve( MapSize, Map, NumToBlacken, IslandSize, NoOfIslands, Island, BlackenedIslands, Result ) :-
length(Island, IslandLength),
IslandLength = IslandSize, % Island is full
!, % No more full-island predicates
border( MapSize, Island, Border ), % Get the islands border
set_and( Map, Border, NBorder ),
set_sum( NBorder, BlackenedIslands, NBlackenedIslands ),
set_diff( Map, NBorder, NMap ), % Blacken those elements of the border that
% belong to the map, and delete them from the map
length(NBlackenedIslands, NBLength),
NBLength =< NumToBlacken, % Check if the length of black hexagons is correct
NNoOfIslands is NoOfIslands - 1, % Decrement the number of islands
dosolve( MapSize, NMap, NumToBlacken, IslandSize, NNoOfIslands, [], NBlackenedIslands, Result ).
% Island not empty and not full, add to the island
dosolve( MapSize, Map, NumToBlacken, IslandSize, NoOfIslands, Island, BlackenedIslands, Result ) :-
getadjacent( MapSize, Map, Island, Island, Adjacent ), % Get some adjacent hexagon (if it exists)
delete( Map, Adjacent, NMap ), % Remove it from the map
dosolve( MapSize, NMap, NumToBlacken, IslandSize, NoOfIslands, [Adjacent|Island], BlackenedIslands, Result ).
% Island not empty and not full, add to blacked
dosolve( MapSize, Map, NumToBlacken, IslandSize, NoOfIslands, Island, BlackenedIslands, Result ) :-
getadjacent( MapSize, Map, Island, Island, Adjacent ), % Get some adjacent hexagon (if it exists)
NBlackenedIslands = [Adjacent|BlackenedIslands], % Blacken it
length(NBlackenedIslands, NBLen),
NBLen =< NumToBlacken, % Check if the length of black hexagons is correct
delete( Map, Adjacent, NMap ), % Remove it from the map
dosolve( MapSize, NMap, NumToBlacken, IslandSize, NoOfIslands, Island, NBlackenedIslands, Result ).
%%% BEGIN %%% GENERATE MAP
% Generate the map. Predicate run only once per problem.
generate_map( MapSize, Map ) :-
X is -2*MapSize,
generate_x( MapSize, [], Map, X ).
generate_x( MapSize, Acc, Map, X ) :-
X =< 2*MapSize, !,
MinusMapSize is -MapSize,
generate_y( MapSize, Acc, NAcc, X, MinusMapSize ),
Xn is X + 1,
generate_x( MapSize, NAcc, Map, Xn ).
generate_x( _MapSize, Acc, Acc, _).
generate_y( MapSize, Acc, Map, X, Y ) :-
Y =< 2*MapSize,
Mod is ((X + Y) mod 2),
Mod = 0,
inbounds( MapSize, (X,Y) ), !,
Yn is Y + 1,
generate_y( MapSize, [(X,Y)|Acc], Map, X, Yn).
% Either not Mod == 0 or not in bounds
generate_y( MapSize, Acc, Map, X, Y ) :-
Y =< 2*MapSize, !,
Yn is Y + 1,
generate_y( MapSize, Acc, Map, X, Yn).
% Y > 2*MapSize
generate_y( _, Acc, Acc, _, _).
%%%% END %%%% GENERATE MAP
%%% BEGIN %%% NEIGHBOURHOOD-RELATED PREDICATES
% Check to see if (X,Y) is on the map
inbounds( MapSize, (X,Y) ) :-
abs(X, Xabs),
abs(Y, Yabs),
Yabs =< MapSize,
Yabs + Xabs =< 2 * MapSize.
% Checks for adjacency
% Without the fourth argument, returns succesive neighbours
adjacent( MapSize, Elem, NElem ) :-
adjacent( MapSize, Elem, NElem, _). % Wrapper
% With the fourth argument, returns a neighbour that lies in the direction N ([1..6])
adjacent( MapSize, (X,Y), (Xn,Yn), N) :-
adjacent_pair(N, (Xa,Ya)), % Get new potential neighbour vector
Xn is X + Xa,
Yn is Y + Ya,
inbounds(MapSize, (Xn,Yn)). % Check, if the new element is in bounds
% Assemble a list of all valid neighbours
adjacent_list( MapSize, Elem, List ) :-
adjacent_list( MapSize, Elem, List, 6).
% The fourth argument is the direction.
adjacent_list( _, _, [], 0 ) :- !.
% A neighbour in the direction N exists:
adjacent_list( MapSize, Elem, [NElem|List], N) :-
adjacent( MapSize, Elem, NElem, N), !,
Nn is N - 1,
adjacent_list( MapSize, Elem, List, Nn).
% A neighbour in the direction N doesn't exist:
adjacent_list( MapSize, Elem, List, N) :-
Nn is N - 1,
adjacent_list( MapSize, Elem, List, Nn).
% Hardcoded adjacency pairs
adjacent_pair(1, ( 2, 0)).
adjacent_pair(2, ( 1,-1)).
adjacent_pair(3, (-1,-1)).
adjacent_pair(4, (-2, 0)).
adjacent_pair(5, (-1, 1)).
adjacent_pair(6, ( 1, 1)).
% Get a border list of an island (All hexagons adjacent to all elements of the island, excluding the island itself)
border( MapSize, Island, Neighbhd ) :-
border( MapSize, Island, [], Neighbhd_incl ), % The ternary border predicate returns a neighbourhood
% with the island included...
set_diff( Neighbhd_incl, Island, Neighbhd ). % ...so it needs to be excluded.
border( _, [], Acc, Acc ) :- !.
border( MapSize, [P|Island], Acc, Neighbhd ) :-
adjacent_list( MapSize, P, List ), % Get a list of all hexagons adjacent to an element
set_sum( List, Acc, Sum ), % For uniqueness
border( MapSize, Island, Sum, Neighbhd ).
% Return an element adjacent to the island, that is on the map
getadjacent( MapSize, Map, WholeIsland, [Elem|_], Adj ) :-
adjacent( MapSize, Elem, Adj ), % Get an element adjacent to some element of the island...
\+ memberchk( Adj, WholeIsland), % ...that is not in the island...
memberchk( Adj, Map ), !. % ...but is on the map
% If that failed, check another element of the island for neighbours
getadjacent( MapSize, Map, WholeIsland, [_|Island], Adj ) :-
getadjacent( MapSize, Map, WholeIsland, Island, Adj ).
%%%% END %%%% NEIGHBOURHOOD-RELATED PREDICATES
%%% BEGIN %%% MATHEMATICAL PREDICATES
% Absolute value of a number
abs(X, Y) :- X >= 0, !, Y is X.
abs(X, Y) :- Y is -X.
% Calculate a sum of two sets (Set1 OR Set2)
set_sum( Set1, Set2, Sum ) :-
set_sum( Set1, Set2, Set2, Sum ).
set_sum( [], _, Acc, Acc ) :- !.
set_sum( [E|Set1], Set2, Acc, Sum ) :-
memberchk( E, Set2 ), !,
set_sum( Set1, Set2, Acc, Sum ).
set_sum( [E|Set1], Set2, Acc, Sum ) :-
set_sum( Set1, Set2, [E|Acc], Sum ).
% Calculate an intersection of two sets (Set1 AND Set2)
set_and( Set1, Set2, And ) :-
set_and( Set1, Set2, [], And ).
set_and( [], _, Acc, Acc ) :- !.
set_and( [E|Set1], Set2, Acc, And ) :-
memberchk( E, Set2 ), !,
set_and( Set1, Set2, [E|Acc], And ).
set_and( [_|Set1], Set2, Acc, And ) :-
set_and( Set1, Set2, Acc, And ).
% Calculate a difference of two sets (Set1/Set2)
set_diff( Set1, Set2, Diff ) :-
set_diff( Set1, Set2, [], Diff ).
set_diff( [], _, Acc, Acc ) :- !.
set_diff( [X|Set1], Set2, Acc, Diff ) :-
memberchk( X, Set2 ), !,
set_diff( Set1, Set2, Acc, Diff ).
set_diff( [X|Set1], Set2, Acc, Diff ) :-
set_diff( Set1, Set2, [X|Acc], Diff ).
%%%% END %%%% MATHEMATICAL PREDICATES
SWI-Prolog
/*
* Usage:
* run("{write 2;}").
* or
* run_file('prog.imp').
* |: 99.
* Read requires it's input to be terminated by a comma ('.')
* Only numbers can be entered.
*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% LEXER %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Convert the input string into a list of tokens. Invalid characters ($,&,...) produce an error.
lexer(Lo,[Token|Tokens]) -->
white(Lo,L), % Dispose of white spaces
(
% Arithmetic operators
"+", !, { Token = tokAdd };
"-", !, { Token = tokSub };
"/", !, { Token = tokDiv };
"*", !, { Token = tokMul };
"%", !, { Token = tokMod };
% Arithmetic relations
"<=", !, { Token = tokLeq };
"<", !, { Token = tokLt };
">=", !, { Token = tokGeq };
">", !, { Token = tokGt };
"=", !, { Token = tokAssgn };
"!=", !, { Token = tokNeq };
% Boolean relations
"&&", !, { Token = tokAnd };
"||", !, { Token = tokOr };
"\!", !, { Token = tokNot };
% Other operators
";", !, { Token = tokSColon };
",", !, { Token = tokComma };
"(", !, { Token = tokLParen };
")", !, { Token = tokRParen };
"[", !, { Token = tokLSquare };
"]", !, { Token = tokRSquare };
"{", !, { Token = tokLCurly };
"}", !, { Token = tokRCurly };
% Control flow, builtin functions, etc
dnumf(Numf), !, lexnum(Numf, Number), { Token = tokNum(Number) };
csymf(Symf), !, lexsym(Symf, Symbol), {
% Symbol is either a reserved name...
memberchk( (Symbol, Token), [ (if, tokIf(L)),
(else, tokElse),
(while, tokWhile(L)),
(abort, tokAbort(L)),
(var, tokVar(L)),
(read, tokRead(L)),
(write, tokWrite(L))]), !
; % OR
% ...or a variable name
Token = tokVariable(Symbol)
};
[X], { throw(errUnknowntoken(L,X)) } % Unknown token error
), !,
lexer(L,Tokens).
lexer(L,[]) --> white(L,_), !.
lexer(_,[]) --> [].
% Comments and whitespaces call each other to make constructs like this valid: "/*a*/ /*a*/ /*a*/"
% C-style comments
comment(L,Ln) --> "/*", !, uncomment(L,Ln).
comment(L,L) --> [].
uncomment(L,Ln) --> "*/", !, white(L,Ln).
uncomment(L,Ln) --> [Char], { code_type(Char, newline), Lnn is L + 1 }, !, uncomment(Lnn,Ln).
uncomment(L,Ln) --> [_], uncomment(L,Ln).
% Eat up whitespaces
white(L,Ln) --> [Char], { code_type(Char, newline), Lnn is L + 1 }, !, white(Lnn, Ln).
white(L,Ln) --> [Char], { code_type(Char, space) }, !, white(L,Ln).
white(L,Ln) --> comment(L,Ln), !.
white(L,L) --> [].
% Valid c (imp) symbols start with a letter or an underscore and later consists of letters, digits or underscores
csymf(X) --> [X], {code_type(X, csymf)}.
csym([X|Xs]) --> [X], {code_type(X, csym)}, !, csym(Xs).
csym([]) --> [].
% Read a string and convert it to a lexem
lexsym(First, Lex) --> csym(Strlex), { atom_codes(Lex, [First|Strlex]) }.
% Decimal number
dnumf(X) --> [X], { code_type(X, digit) }.
dnum([X|Xs]) --> [X], { code_type(X, digit) }, !, dnum(Xs).
dnum([]) --> [].
% Read a string and convert it to a number
lexnum(First, Num) --> dnum(Strnum), {number_chars(Num, [First|Strnum])}.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% PARSER %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- op(900, xfy, :=).
% Program, block, empty
program([Ast]) --> blok(Ast), !.
blok(block(Instrs)) --> [tokLCurly], !, instructions(Instrs), [tokRCurly], !.
empty --> [].
% Instructions
instructions([Instr|Rest]) --> instruction(Instr), instructions(Rest), !.
instructions([]) --> empty.
instruction(abort) --> [tokAbort(_)], [tokSColon], !.
instruction(var(Instr)) --> [tokVar(_)], declarators(Decle_rs), [tokSColon], {flatten(Decle_rs,Instr)},!.
instruction(Cell:=Expr) --> cell(Cell), [tokAssgn], expr(Expr), [tokSColon], !.
instruction(read(Cell)) --> [tokRead(_)], cell(Cell), [tokSColon], !.
instruction(write(Expr)) --> [tokWrite(_)], expr(Expr), [tokSColon], !.
instruction(if(Bool,Then,Else)) --> [tokIf(_)], [tokLParen], expr(Bool), [tokRParen], instruction(Then),
[tokElse], instruction(Else), !.
instruction(if(Bool,Then)) --> [tokIf(_)], [tokLParen], expr(Bool), [tokRParen], instruction(Then), !.
instruction(while(Bool,Body)) --> [tokWhile(_)], [tokLParen], expr(Bool), [tokRParen], instruction(Body), !.
instruction(Instr) --> blok(Instr), !.
% Errors
instruction(_) --> [tokAbort(L)], { throw(errParsercf(L,abort)) }.
instruction(_) --> [tokVar(L)], { throw(errParsercf(L,var)) }.
instruction(_) --> [tokRead(L)], { throw(errParsercf(L,read)) }.
instruction(_) --> [tokWrite(L)], { throw(errParsercf(L,write)) }.
instruction(_) --> [tokIf(L)], { throw(errParsercf(L,if)) }.
instruction(_) --> [tokWhile(L)], { throw(errParsercf(L,while)) }.
% Other errors are not reported in detail, and are thrown by the "run" predicate.
% Declarators
declarators([Decle_r|Rest]) --> declarator(Decle_r), [tokComma], !, declarators(Rest).
declarators([Decle_r]) --> declarator(Decle_r).
declarator((variable(Ide)=Expr)) --> [tokVariable(Ide)], [tokAssgn], expr(Expr).
declarator(array(Ide,[Expr])) --> [tokVariable(Ide)], [tokLSquare], expr(Expr), [tokRSquare].
declarator(variable(Decle_r)) --> [tokVariable(Decle_r)].
% Cell, expr
cell(array(Ide,[Expr])) --> [tokVariable(Ide)], [tokLSquare], !, expr(Expr), [tokRSquare].
cell(variable(Ide)) --> [tokVariable(Ide)].
expr(or(E1,E2)) --> disjunct(E1), [tokOr], !, expr(E2).
expr(Expr) --> disjunct(Expr).
% Disjunct, conjunct
disjunct(and(E1,E2)) --> conjunct(E1), [tokAnd], !, disjunct(E2).
disjunct(Expr) --> conjunct(Expr).
conjunct(Conjunct) --> arith_expr(LExpr), op_rel(=), !, arith_expr(RExpr),
{ Conjunct =.. [=, LExpr, RExpr] }.
conjunct(Conjunct) --> arith_expr(LExpr), op_rel(Op), !, arith_expr(RExpr),
{ Conjunct =.. [Op, LExpr, RExpr] }.
conjunct(Conjunct) --> arith_expr(Conjunct).
% Arithmetic expression, summand, factor. An accumulator is needed for correcness of 2-2-2 etc.
arith_expr(Expr) --> summand(Summand), arith_expr(Summand, Expr).
arith_expr(Acc, Expr) --> op_add(Op), !, summand(Summand),
{ Acc1 =.. [Op, Acc, Summand] }, arith_expr(Acc1, Expr).
arith_expr(Acc, Acc) --> [].
summand(Expr) --> factor(Factor), summand(Factor, Expr).
summand(Acc, Expr) --> op_mult(Op), !, factor(Factor),
{ Acc1 =.. [Op, Acc, Factor] }, summand(Acc1, Expr).
summand(Acc, Acc) --> [].
factor(not(Expr)) --> [tokNot], factor(Expr).
factor(neg(Expr)) --> [tokSub], factor(Expr).
factor(constant(N)) --> [tokNum(N)].
factor(cell(Var)) --> cell(variable(Var)).
factor(array(A,B)) --> cell(array(A,B)).
factor(Expr) --> [tokLParen], expr(Expr), [tokRParen].
% Additive operators
op_add(+) --> [tokAdd].
op_add(-) --> [tokSub].
% Multiplicative operators
op_mult(*) --> [tokMul].
op_mult(//) --> [tokDiv].
op_mult(mod) --> [tokMod].
% Arithmetic relations
op_rel(<) --> [tokLt].
op_rel(=<) --> [tokLeq].
op_rel(>) --> [tokGt].
op_rel(>=) --> [tokGeq].
op_rel(=) --> [tokAssgn].
op_rel(=\=) --> [tokNeq].
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% INTERPRETER %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Lookup a variable value (write x)
lookup(M, X, _) :- memberchk((_,X,$non), M), !, throw(errUninited(X)). % Error, uninitialized
lookup(M, X, N) :- memberchk((_,X,N), M), !.
lookup(_, X, _) :- throw(errNonexistent(X)). % Error, nonexistent
% Lookup an array value (write x[7])
lookuparray([(_,array(X,L),V)|_],X,I,N) :- L >= I, I >= 0, memberchk( (I,N), V).
lookuparray([(_,array(X,L),_)|_],X,I,_) :- L >= I, I >= 0, !, throw(errUninited(X,I)).
lookuparray([(_,array(X,L),_)|_],X,I,_) :- !, throw(errOutofbounds(X,L,I)). % Error, out of bounds
lookuparray([_|M],X,I,N) :- !, lookuparray(M,X,I,N).
% Create a new array (var x[17])
newarray([(D,X,N)|M], Xn, Nn, [(D,array(Xn,Nnn),[]),(D,X,N)|M])
:- \+ memberchk((D,array(Xn,_),_), [(D,X,N)|M]), Nn > 0, !, Nnn is Nn-1.
newarray([(D,X,N)|M], Xn, Nn, _) :- \+ memberchk((D,array(Xn,_),_), [(D,X,N)|M]), throw(errArraytosmall(Xn,Nn)).
newarray([(D,_,_)|_], Xn, _, _) :- throw(errRedeclr(Xn,D)). % Error, redeclared
% Create a new variable (var x)
newvar([(D,X,N)|M], Xn, Nn, [(D,Xn,Nn),(D,X,N)|M]) :- \+ memberchk((D,Xn,_), [(D,X,N)|M]), !.
newvar([(D,_,_)|_], Xn, _, _) :- throw(errRedeclr(Xn,D)). % Error, redeclared
% Update an array element (x[7] = 1)
updatearrayval([], I, N, [(I,N)]) :- !.
updatearrayval([(I,_)|V], I, N, [(I,N)|V]) :- !.
updatearrayval([E|V], I, N, [E|Vn]) :- updatearrayval(V, I, N, Vn).
updatearray([(D,array(X,L),V)|T], X, I, N, [(D,array(X,L),Vn)|T]) :- L >= I, I >= 0, !, updatearrayval(V, I, N, Vn).
updatearray([(D,array(X,L),_)|T], X, I, N, [(D,array(X,L),_)|T]) :- throw(errOutofbounds(X,N,L,I)).
updatearray([A|T], X, I, N, [A|S]) :- updatearray(T, X, I, N, S).
% Update a variable (x = 2)
updatevar([], X, N, []) :- throw(errNonexistent(X,N)).
updatevar([(D,X,_)|T], X, N, [(D,X,N)|T]) :- !.
updatevar([A|T], X, N, [A|S]) :- updatevar(T, X, N, S).
% Delete a block of variables (var x; {var x;})
delblock(D, [(D,_,_)|M], MN) :- !, delblock(D, M, MN).
delblock(_, M, M).
:- op(800, xfy, =>).
% Open and end block ({...})
([block(CS)|C], R, [(D,X,N)|M]) => (CN, R, [(DN,$non,$non),(D,X,N)|M]) :-
DN is D + 1, append(CS, [endblock|C], CN).
([endblock|C], R, [(D,_,_)|M]) => (C,R,MN) :- delblock(D, M, MN).
% Variable declaration (var x,y[z]...)
([var([])|C], R, M) => (C, R, M).
([var([variable(X)|Vars])|C], R, M1) => ([var(Vars)|C], R, M2) :- newvar(M1, X, $non, M2).
([var([variable(X)=constant|Vars])|C], [N|R], M1) => ([var(Vars)|C], R, M2) :- newvar(M1, X, N, M2).
([var([variable(X)=A|Vars])|C], R, M) => ([A,var([variable(X)=constant|Vars])|C], R, M).
([var([array(X,[A])|Vars])|C], R, M) => ([A, var([array(X)|Vars])|C], R, M).
([var([array(X)|Vars])|C], [N|R], M1) => ([var(Vars)|C], R, M2) :- newarray(M1, X, N, M2).
% Arrays, constants, cells, variables...
([array(X,[A])|C], R, M) => ([A,array(X)|C], R, M).
([constant(N)|C], R, M) => (C, [N|R], M).
([cell(X)|C], R, M) => (C, [N|R], M) :- lookup(M, X, N), !.
([variable(X) | C], R, M) => (C, [X|R], M).
% Arithmetic operators
([A|C], R, M) => ([A1, A2, Op | C], R, M) :- A =.. [Op, A1, A2], memberchk(Op, [+,-,*,//,mod]).
([Op|C], [N2,N1|R], M) => (C, [N|R], M) :- memberchk(Op, [+,-,*,mod]), A =.. [Op, N1, N2], N is A.
([//|C], [N2,N1|R], M) => (C, [N|R], M) :- N2 is 0 -> throw(errDivisionbyzero(N1,N2)) ; N is N1 // N2.
% Boolean and arithmetic relations
([B|C], R, M) => ([A1,A2,Op|C], R, M) :- B =.. [Op, A1, A2], memberchk(Op, [<,>,>=,=<,=\=,=]).
([Op|C], [N2,N1|R], M) => (C, [B|R], M) :- memberchk(Op, [<,>,>=,=<,=\=,=]),
(call(Op, N1, N2) -> B = 1; B = 0).
% minus: -5, -x, -x[3], etc
([neg(A)|C], R, M) => ([A,neg|C], R, M).
([neg|C], [N|R], M) => (C, [Nn|R], M) :- Nn is -N.
% not: !1, !(1<2), etc
([not(B)|C], R, M) => ([B,not|C], R, M). % !_
([not|C], [0|R], M) => (C, [1|R], M) :- !. % !false
([not|C], [_|R], M) => (C, [0|R], M). % !true
% Lazy "&&" and "||": x && y, 1 < x || 1 < y, etc
([and(B1,B2)|C], R, M) => ([B1,and(B2)|C], R, M). % _ && _
([and(_)|C], [0|R], M) => (C, [0|R], M) :- !. % false && _
([and(B2)|C], [_|R], M) => ([B2|C], R, M). % true && _
([or(B1,B2)|C], R, M) => ([B1,or(B2)|C], R, M). % _ || _
([or(B2)|C], [0|R], M) => ([B2|C], R, M) :- !. % false || _
([or(_)|C], [_|R], M) => (C, [1|R], M). % true || _
([or|C], [0|R], M) => (C, [0|R], M). % false || false
% assign, if, while, abort...
([B|C], R, M) => ([N, X, := | C], R, M) :- B =.. [:=, X, N].
([:=|C], [X,N|R], M1) => (C, R, M2) :- updatevar(M1,X,N,M2).
([array(X), :=|C], [I,N|R], M1) => (C, R, M2) :- updatearray(M1,X,I,N,M2).
([array(X) | C], [I|R], M) => (C, [Nn|R], M) :- lookuparray(M,X,I,Nn).
([if(B,C1)|C], R, M) => ([B,if|C], [C1|R], M).
([if|C], [0,_C1|R], M) => (C, R, M) :- !.
([if|C], [_,C1|R], M) => ([C1|C], R, M).
([if(B,C1,C2)|C], R, M) => ([B,if_else|C], [C1,C2|R], M).
([if_else|C], [0, _C1, C2 | R], M) => ([C2|C], R, M) :- !.
([if_else|C], [_, C1, _C2 | R], M) => ([C1|C], R, M).
([while(B,C1)|C], R, M) => ([B, while | C], [B, C1 | R], M).
([while|C], [0, _B, _C1 | R], M) => (C, R, M) :- !.
([while|C], [_, B, C1 | R], M) => ([C1,while(B,C1)|C], R, M).
% Just terminate
([abort|_], _, _) => ([],[],[]).
% Read, write
([read(variable(X))|C], R, M) => ([:=|C], [X,N|R], M) :- read(N).
([write(X)|C], R, M) => ([X,write|C], R, M).
([write|C], [X|R], M) => (C, R, M) :- write(X), nl.
:- op(800, xfy, *=>).
% Run the program
InitState *=> FinState :-
InitState => NextState, !,
NextState *=> FinState.
FinState *=> FinState.
% Debugger
debugger(InitState) :-
InitState => NextState, !,
write(InitState), nl,
debugger(NextState).
debugger(FinState) :- write(FinState), nl.
% Run lexer and then parse it's output
parse(CharCodeList, Absynt) :-
phrase(lexer(1,TokList), CharCodeList),
phrase(program(Absynt), TokList).
% Run from a file, or from the argument (run_file('prog.imp'), run("{write 1;}").)
run_file(File) :- read_file_to_codes(File, Prog, []), run(Prog).
run(Prog) :- catch(dorun(Prog), X, errormsg(X)).
dorun(Prog) :- parse(Prog, P) -> ((P,[],[(0,$non,$non)]) *=> _); throw(errSyntax).
% Run through a debugger.
drun_file(File) :- read_file_to_codes(File, Prog, []), drun(Prog).
drun(Prog) :- catch(ddorun(Prog), X, errormsg(X)).
ddorun(Prog) :- parse(Prog, P) -> debugger((P, [], [(0,$non,$non)])); throw(errSyntax).
% Error messages
errormsg(errUnknowntoken(L,X)) :- !, writef("Illegal char \"%n\" on line %d.",[X,L]).
% Only selected errors are reported in detail
errormsg(errParsercf(L,I)) :- !, writef("Incorrect syntax of \"%d\" on line %d.",[I,L]).
errormsg(errSyntax) :- !, writef("Incorrect syntax").
% Runtime errors
errormsg(errOutofbounds(X,L,I)) :- !, Ln is L+1,
writef("Array element \"%d[%d]\" is out of bounds. Array has only %d elements.",[X,I,Ln]).
errormsg(errOutofbounds(X,N,L,I)) :- !, Ln is L+1,
writef("Array out of bounds: \"%d[%d] = %d\". Array has only %d elements.",[X,I,N,Ln]).
errormsg(errUninited(X)) :- !, writef("Variable \"%d\" is uninitialized",[X]).
errormsg(errUninited(X,N)) :- !, writef("Array element \"%d[%d]\" is uninitialized",[X,N]).
errormsg(errNonexistent(X)) :- !, writef("Attempting to read from a nonexistent variable \"%d\".",[X]).
errormsg(errNonexistent(X,N)) :- !, writef("Attempting to write \"%d\" to a nonexistent variable \"%d\".",[N,X]).
errormsg(errRedeclr(X,D)) :- !, writef("\"%d\" has already been declared in scope level %d.",[X,D]).
errormsg(errArraytosmall(X,N)) :- !, writef("Array size to small: \"var %d[%d]\".",[X,N]).
errormsg(errDivisionbyzero(N1,N2)) :- !, writef("Division by zero: \"%d/%d\".",[N1,N2]).
errormsg(X) :- !, writef("Error: \"%d\"", [X]).
Z użyciem list.
{-
Caution: An empty element is denoted as Wire []
Usage:
netwalk configuration
ghci> netwalk [[Source [Right,Down], Wire [Left, Down]],[PC Up, PC Up]]
[[0,0],[0,0]]
-}
import Prelude hiding (Right, Left) -- to avoid confusion
import List -- unfoldr
import Maybe -- fromMaybe
type Configuration = [[Field]]
type Conflist = [Field] -- flattened Configuration
type YXPair = (Int,Int)
data Field = Wire [Direction] | Source [Direction] | PC Direction
deriving (Read, Show, Eq)
data Direction = Up | Right | Down | Left
deriving (Read, Show, Eq, Ord) -- Ord is for sort
type Solution = [[Turn]] -- sometimes -1 is the same as 1
type Turn = Int -- -1 .. 2
-- Interactive
main = do
configuration <- readLn :: IO Configuration
print $ netwalk configuration
-- Main function
netwalk :: Configuration -> [Solution]
netwalk configuration =
let list = foldl (++) [] configuration -- flatten the input list
maxyx = (length configuration, length $ head configuration) -- maxyx = (maxy,maxx), max_ >= 1
in
concatMap (\xs -> if checkConnectivity maxyx xs then [reformat maxyx list xs] else []) (solve maxyx [] list)
-- Try to rotate a piece in four different ways
solve :: YXPair -> Conflist -> Conflist -> [Conflist]
solve _ result [] = [result]
solve maxyx result (x:xs) =
(if (rotate 0 x) /= Nothing then try maxyx (result ++ fromMaybe [] (rotate 0 x)) xs else []) ++
(if (rotate 1 x) /= Nothing then try maxyx (result ++ fromMaybe [] (rotate 1 x)) xs else []) ++
(if (rotate 2 x) /= Nothing then try maxyx (result ++ fromMaybe [] (rotate 2 x)) xs else []) ++
(if (rotate 3 x) /= Nothing then try maxyx (result ++ fromMaybe [] (rotate 3 x)) xs else [])
-- [] means failure ([] is not a valid netwalk map, therefore we can use it in this way)
try :: YXPair -> Conflist -> Conflist -> [Conflist]
try maxyx result xs = if isProperlyConnected maxyx ((length result) - 1) result then solve maxyx result xs else []
-- Check if on map
inBounds :: YXPair -> YXPair -> Bool
inBounds (maxy, maxx) (y, x) | y >= 0 && x >= 0 && y < maxy && x < maxx = True
| otherwise = False
-- Check if Field contains Direction
hasDirNoBounds :: Direction -> Field -> Bool
hasDirNoBounds dir (Wire list) = elem dir list
hasDirNoBounds dir (Source list) = elem dir list
hasDirNoBounds dir (PC list) = dir == list
-- If Field exists, check if it contains Direction
hasDir :: YXPair -> Int -> Direction -> Conflist -> Bool
hasDir maxyx n dir list = if inBounds maxyx (ntoyx maxyx n) then
if hasDirNoBounds dir (getN n list) then True else False
else False
-- Checks if Field has a valid connection to it's left and upper neighbour (if it exists)
isProperlyConnected :: YXPair -> Int -> Conflist -> Bool
isProperlyConnected maxyx@(maxy,maxx) n list =
let (y,x) = (ntoyx maxyx n) in
if y == 0 && (hasDir maxyx n Up list) then False
else if y == maxy-1 && (hasDir maxyx n Down list) then False
else if x == 0 && (hasDir maxyx n Left list) then False
else if x == maxx-1 && (hasDir maxyx n Right list) then False
else if (hasDir maxyx n Up list) && y-1 >= 0 && not (hasDir maxyx (yxton maxyx (y-1,x)) Down list) then False
else if (hasDir maxyx n Left list) && x-1 >= 0 && not (hasDir maxyx (yxton maxyx (y,x-1)) Right list) then False
else if not (hasDir maxyx n Up list) && y-1 >= 0 && (hasDir maxyx (yxton maxyx (y-1,x)) Down list) then False
else if not (hasDir maxyx n Left list) && x-1 >= 0 && (hasDir maxyx (yxton maxyx (y,x-1)) Right list) then False
else True
-- Rotate clockwise
rotateDirection :: Direction -> Direction
rotateDirection Up = Right
rotateDirection Right = Down
rotateDirection Down = Left
rotateDirection Left = Up
-- Rotate a list clockwise
rotateList :: [Direction] -> [Direction]
rotateList [] = []
rotateList (x:xs) = rotateDirection x : rotateList xs
-- Rotate a Field clockwise
rotateElement :: Field -> Field
rotateElement (Wire list) = Wire (rotateList list)
rotateElement (Source list) = Source (rotateList list)
rotateElement (PC dir) = PC (rotateDirection dir)
-- Rotate a Field clockwise, n times. rotate 0 = rotate 2 for [Left,Right] etc.
rotate :: Int -> Field -> Maybe [Field]
rotate 0 field = Just [field]
rotate _ field@(Wire l) | sort l == sort [Left,Right,Up,Down] = Nothing
rotate _ field@(Source l) | sort l == sort [Left,Right,Up,Down] = Nothing
rotate _ field@(Wire []) = Nothing
rotate 1 field = Just $ [rotate' 1 field]
rotate _ field@(Wire l) | sort l == sort [Left,Right] = Nothing
| sort l == sort [Up,Down] = Nothing
rotate _ field@(Source l) | sort l == sort [Left,Right] = Nothing
| sort l == sort [Up,Down] = Nothing
rotate 2 field = Just $ [rotate' 2 field]
rotate 3 field = Just $ [rotate' 3 field]
rotate' :: Int -> Field -> Field
rotate' 0 field = field
rotate' n field = rotate' (n-1) (rotateElement field)
{- ******************************** Check connectivity ********************************* -}
type EnumeratedField = (YXPair,Field)
type EnumeratedConflist = [EnumeratedField] -- Conflist with coordinates
checkConnectivity :: YXPair -> Conflist -> Bool
checkConnectivity maxyx list = checkConn listNoEmpty listEmpty [source]
where
enumeratedList = enumerateConflist maxyx 0 list
source@(sourceYX,_) = getSource enumeratedList
listNoSource = delYX sourceYX enumeratedList
(listEmpty,listNoEmpty) = checkConnAddEmpty listNoSource [] []
-- Add all empty elements to one graph
checkConnAddEmpty :: EnumeratedConflist -> EnumeratedConflist -> EnumeratedConflist -> (EnumeratedConflist,EnumeratedConflist)
checkConnAddEmpty [] list1 list2 = (list1,list2)
checkConnAddEmpty (el@(yx,Wire []):list) list1 list2 = checkConnAddEmpty list (el:list1) (list2)
checkConnAddEmpty (el:list) list1 list2 = checkConnAddEmpty list (list1) (el:list2)
-- Check to see if the graph is connective
checkConn :: EnumeratedConflist -> EnumeratedConflist -> EnumeratedConflist -> Bool
checkConn input result [] = containsOnlyWires input
where
containsOnlyWires [] = True
containsOnlyWires ((yx,Wire _):list) = containsOnlyWires list
containsOnlyWires _ = False
checkConn input result (el@((y,x),val):buffer) = checkConn input' (el:result) (buffer ++ bufs)
where
getUp = if hasDirNoBounds Up val then getYX (y-1,x) input else Nothing
getDown = if hasDirNoBounds Down val then getYX (y+1,x) input else Nothing
getLeft = if hasDirNoBounds Left val then getYX (y,x-1) input else Nothing
getRight = if hasDirNoBounds Right val then getYX (y,x+1) input else Nothing
bufs = concatMap (\x -> if x == Nothing then [] else [fromJust x]) [getUp,getDown,getLeft,getRight]
input' = input \\ bufs
{- ***************************** Formating, list operations ********************************* -}
-- Reformat a list of Fields into Solution
-- Sometimes -1 is the same as 1 (Wire [Left, Right])
reformat :: YXPair -> Conflist -> Conflist -> Solution
reformat (maxy,maxx) xs ys = unfoldr (\x -> if x == [] then Nothing else Just $ splitAt maxx x) $ reformatFlat xs ys
-- unfoldr deflattenes a list
-- Convert from Conflist to [Turn]. For input (PC Right) and (PC Down) this function gives 1
reformatFlat :: Conflist -> Conflist -> [Turn]
reformatFlat [] [] = []
reformatFlat (x:xs) (y:ys) =
( if x == rotate' 0 y then 0
else if x == rotate' 1 y then 1
else if x == rotate' 2 y then 2
else -1)
: reformatFlat xs ys
-- Let all elements of a 1D list hold the coordinates of an element
enumerateConflist :: YXPair -> Int -> Conflist -> EnumeratedConflist
enumerateConflist maxyx n [] = []
enumerateConflist maxyx n (x:xs) = (ntoyx maxyx n,x) : (enumerateConflist maxyx (n+1) xs)
-- Remove above-mentioned coordinates
removeCoordinates :: EnumeratedConflist -> Conflist
removeCoordinates [] = []
removeCoordinates (x:xs) = (snd x) : (removeCoordinates xs)
getSource :: EnumeratedConflist -> EnumeratedField
getSource (el@(_,Source _):xs) = el
getSource (el:xs) = getSource xs
delYX :: YXPair -> EnumeratedConflist -> EnumeratedConflist
delYX yx (el@(yx',val):xs) | yx == yx' = xs
| otherwise = el : delYX yx xs
getYX :: YXPair -> EnumeratedConflist -> Maybe EnumeratedField
getYX yx [] = Nothing
getYX yx (el@(yx',val):xs) | yx == yx' = Just el
| otherwise = getYX yx xs
-- Convert between (y,x) to n and back
yxton :: YXPair -> YXPair -> Int
yxton (maxy, maxx) (y,x) = y*maxx + x
ntoyx :: YXPair -> Int -> YXPair
ntoyx (maxy, maxx) n = (n `div` maxx, n `mod` maxx)
-- Get n'th Field
getN :: Int -> Conflist -> Field
getN n xs = xs !! n
Z użyciem list.
{-
Interactive usage in ghci:
arrows [[Left]]
-}
import Prelude hiding (Right, Left) -- to avoid confusion
import List
import Maybe
{- ****************************************************************************************** -}
type Board = [[Field]]
data Field = Up | Right | Down | Left | UpN Int | RightN Int | DownN Int | LeftN Int |
UpL [Int] | RightL [Int] | DownL [Int] | LeftL [Int] -- auxilary constructors
deriving (Read, Show, Eq)
type Conflist = [Field] -- flattened Configuration
type EnumeratedField = (YXPair,Field)
type EnumeratedConflist = [EnumeratedField] -- Conflist with coordinates
type YXPair = (Int,Int)
type Solution = [[Numbr]]
type Numbr = Int -- 1 .. n-1
-- Interactive
main = do
board <- readLn :: IO Board
print $ arrows board
-- Main predicate
arrows :: Board -> Board
arrows board =
let list = foldl (++) [] board -- flatten the input list
maxyx = (length board, length $ head board) -- maxyx = (maxy,maxx), max_ >= 1
enumList = enumerateConflist maxyx 0 list -- reformat the input list
bordered = map (arrowBorder maxyx) enumList -- simple optimization, adds _N 0
rnged = map (arrowRng maxyx bordered) bordered -- adds [min..max] fields. After this
-- there are no more Up, Right etc
-- (only UpL, RightL...)
ltoned = map (arrowLtoN) rnged -- convert UpL [x] to UpN x
optimized = arrowOptimize maxyx ltoned -- optimize input as much as possible
-- (greatly decreases runtime)
in
head $ (map (reformat maxyx) $ map removeCoordinates $ concatMap (\xs -> if checkMap maxyx xs xs then [xs] else []) $ solve maxyx optimized []) ++ [[]]
-- append an empty list, so that head will always succeed
-- NOTE: Displaying all results can be achieved by removing "head" from the above function.
-- The type of the function will change.
{- **************************************** FORMATTING ***************************************** -}
-- Convert 1D list to 2D
reformat :: YXPair -> Conflist -> Board
reformat (maxy,maxx) list = unfoldr (\x -> if x == [] then Nothing else Just $ splitAt maxx x) list
-- Let all elements of a 1D list hold the coordinates of an element
enumerateConflist :: YXPair -> Int -> Conflist -> EnumeratedConflist
enumerateConflist maxyx n [] = []
enumerateConflist maxyx n (x:xs) = (ntoyx maxyx n,x) : (enumerateConflist maxyx (n+1) xs)
-- Remove above-mentioned coordinates
removeCoordinates :: EnumeratedConflist -> Conflist
removeCoordinates [] = []
removeCoordinates (x:xs) = (snd x) : (removeCoordinates xs)
{- ************************************** SOLVING THE MAP ************************************** -}
-- Protection from malicious input, like [[LeftN 10]].
-- The function checkMap checks a solved map to see if it is correct, using no optimization at all.
-- Caution: If we assume that input may not be malicious then these two function are useless!
countDN :: [Field] -> Int
countDN list = length $ nub list' where
list' = [fromJust (arrowGetValN e) | e <- list]
checkMap :: YXPair -> EnumeratedConflist -> EnumeratedConflist -> Bool
checkMap (maxy,maxx) [] list = True
checkMap (maxy,maxx) (((y,x),val):xs) list =
if arrowIsUpN val then
if (fromJust $ arrowGetValN val) == countDN ([getYX (y',x) list | y' <- [0..y-1]]) then
checkMap (maxy,maxx) xs list
else False
else if arrowIsDownN val then
if (fromJust $ arrowGetValN val) == countDN ([getYX (y',x) list | y' <- [y+1..maxy-1]]) then
checkMap (maxy,maxx) xs list
else False
else if arrowIsLeftN val then
if (fromJust $ arrowGetValN val) == countDN ([getYX (y,x') list | x' <- [0..x-1]]) then
checkMap (maxy,maxx) xs list
else False
else -- if arrowIsRightN val then
if (fromJust $ arrowGetValN val) == countDN ([getYX (y,x') list | x' <- [x+1..maxx-1]]) then
checkMap (maxy,maxx) xs list
else False
-- Return all valid results. Solve uses an accumulator.
-- The function solve' is ugly (it's arguments are), but it's quite fast. The number of calculations
-- required is minimal (without this optimization some calculations would need to be performed multiple times).
solve :: YXPair -> EnumeratedConflist -> EnumeratedConflist -> [EnumeratedConflist]
solve maxyx [] acc = [reverse acc]
solve maxyx@(my,mx) ((el@(yx@(y,x),val)):list) acc
| arrowSure val = solve maxyx list (el:acc)
| otherwise = -- val == _L [a,b,c...] -- at this point val cannot be Up, Down etc
solve' maxyx (head p) (last p) (last p) el list acc (vera,verb,hora,horb,vera',verb',hora',horb', (eva,nva), (evb,nvb), (eha,nha), (ehb,nhb))
where
p = fromJust $ arrowGetValL val
{- (vera)
(hora) el (horb)
(verb) for element el get the column and row it's in. -}
-- get column, row...
vera = map snd $ reverse $ getColumn x acc
verb = map snd $ getColumn x list
hora = map snd $ reverse $ take x acc
horb = map snd $ take (mx-x-1) list
-- get value, if it exists.
-- For Up 2 value = Just 2
-- For UpL [1,2] value = Nothing
vera' = map arrowGetValN $ vera
verb' = map arrowGetValN $ verb
hora' = map arrowGetValN $ hora
horb' = map arrowGetValN $ horb
-- ugly but efficient hack: divide Nothings and Justs
(eva,nva) = partition (== Nothing) $ vera'
(evb,nvb) = partition (== Nothing) $ verb'
(eha,nha) = partition (== Nothing) $ hora'
(ehb,nhb) = partition (== Nothing) $ horb'
-- solve' attempts to assign all possible values to an arrow. If the value is potentially correct it runs solve.
-- Assign values from maximum to minimum (if UpL [1,2,3,4] then start from 4). If a map is large, there is
-- a chance numbers will be large as well. If a map is small it will be solved quickly anyway.
solve' maxyx@(my,mx) start cur end (yx@(y,x),val) list acc tuple@(vera,verb,hora,horb,vera',verb',hora',horb', (eva,nva), (evb,nvb), (eha,nha), (ehb,nhb)) =
if cur < start then [] else
((if (checkMainElement (snd nel) (eva,nva) (evb,nvb) (eha,nha) (ehb,nhb)) &&
(checkElementsHorizontal horizlist horizlist' (ehl,nhl)) &&
(checkElementsVertical vertlist vertlist' (evl,nvl))
then cont
else []) ++ trydifferent)
where
trydifferent = solve' maxyx start (cur-1) end (yx,val) list acc tuple
nel@(_,nval) = (yx,arrowAssign val cur)
cont = solve maxyx list (nel:acc)
(ee,ne) = partition (== Nothing) [arrowGetValN $ snd nel]
(evl,nvl) = (eva++ee++evb,nva++ne++nvb)
(ehl,nhl) = (eha++ee++ehb,nha++ne++nhb)
vertlist = vera ++ (snd nel) : verb
horizlist = hora ++ (snd nel) : horb
vertlist' = vera' ++ (arrowGetValN $ snd nel) : verb'
horizlist' = hora' ++ (arrowGetValN $ snd nel) : horb'
-- count Different Numbers Optimistic, i.e treat unknown values of arrows as potentially being the same
-- as other values in the set.
countDNO :: [Field] -> Int
countDNO list = if len == 0 then 1 else len
where
len = length $ nub $ filter (/= Nothing) list'
list' = [(arrowGetValN e) | e <- list]
-- The same as above, but Pesimistic -- treats unknown values as being different from others.
countDNP :: [Field] -> Int
countDNP list = (length $ nub $ filter (/= Nothing) list') + (length $ filter (== Nothing) list')
where
list' = [(arrowGetValN e) | e <- list]
-- Calculate the range of possible values
countDNOP :: [Field] -> [Int]
countDNOP [] = [0]
countDNOP list = [(countDNO list)..(countDNP list)]
-- Same as above, but most of the work is done by solve'
countDNOP' :: ([Maybe Int],[Maybe Int]) -> [Int]
countDNOP' (eq,neq) = [flistl..(flistl + flistl')]
where
flistl = length $ nub neq
flistl' = length eq
checkElementsHorizontal [] _ _ = True
checkElementsHorizontal (el:elems) (_:wval) ([],_:neqs) =
if (checkElementRight el ([],neqs)) then (checkElementsHorizontal elems wval ([],neqs))
else False
checkElementsHorizontal (el:elems) (_:wval) (_:eqs,[]) =
if (checkElementRight el (eqs,[])) then (checkElementsHorizontal elems wval (eqs,[]))
else False
checkElementsHorizontal (el:elems) (wv:wval) (eq:eqs,neq:neqs) =
if wv == Nothing then
if (checkElementRight el (eqs,neq:neqs)) then (checkElementsHorizontal elems wval (eqs,neq:neqs))
else False
else
if (checkElementRight el (eq:eqs,neqs)) then (checkElementsHorizontal elems wval (eq:eqs,neqs))
else False
checkElementRight val list =
if arrowIsRightN val then
if elem (fromJust $ arrowGetValN val) (countDNOP' list) then True
else False
else True
checkElementsVertical [] _ _ = True
checkElementsVertical (el:elems) (_:wval) ([],_:neqs) =
if (checkElementDown el ([],neqs)) then (checkElementsVertical elems wval ([],neqs))
else False
checkElementsVertical (el:elems) (_:wval) (_:eqs,[]) =
if (checkElementDown el (eqs,[])) then (checkElementsVertical elems wval (eqs,[]))
else False
checkElementsVertical (el:elems) (wv:wval) (eq:eqs,neq:neqs) =
if wv == Nothing then
if (checkElementDown el (eqs,neq:neqs)) then (checkElementsVertical elems wval (eqs,neq:neqs))
else False
else
if (checkElementDown el (eq:eqs,neqs)) then (checkElementsVertical elems wval (eq:eqs,neqs))
else False
checkElementDown val list =
if arrowIsDownN val then
if elem (fromJust $ arrowGetValN val) (countDNOP' list) then True
else False
else True
checkMainElement val vera verb hora horb =
if arrowIsRightN val then
if elem (fromJust $ arrowGetValN val) (countDNOP' horb) then True
else False
else if arrowIsDownN val then
if elem (fromJust $ arrowGetValN val) (countDNOP' verb) then True
else False
else if arrowIsLeftN val then
if [fromJust $ arrowGetValN val] == (countDNOP' hora) then True
else False
else if arrowIsUpN val then
if [fromJust $ arrowGetValN val] == (countDNOP' vera) then True
else False
else False
{- ********************************** INITIAL OPTIMALIZATION *********************************** -}
-- Run only once per problem, no need to be fast
-- The only function that assigns values of 0
arrowBorder :: YXPair -> EnumeratedField -> EnumeratedField
arrowBorder (my,mx) el@(yx@(y,x),val) =
if arrowSure val then el -- Already sure
else if arrowIsUp val && y == 0 then (yx,UpN 0)
else if arrowIsDown val && y == my-1 then (yx,DownN 0)
else if arrowIsLeft val && x == 0 then (yx,LeftN 0)
else if arrowIsRight val && x == mx-1 then (yx,RightN 0)
else el
-- Convert UpL [1] to UpN 1 etc.
arrowLtoN :: EnumeratedField -> EnumeratedField
arrowLtoN el@(yx,val) =
let
list = fromMaybe [] (arrowGetValL val)
singleton [x] = x
in
if (length list == 1) then
if arrowIsUpL val then (yx,UpN $ singleton list)
else if arrowIsDownL val then (yx,DownN $ singleton list)
else if arrowIsLeftL val then (yx,LeftN $ singleton list)
else (yx,RightN $ singleton list)
else
el
-- Assign each Up, Down etc. a maximum range UpL [min..max] etc.
arrowRng :: YXPair -> EnumeratedConflist -> EnumeratedField -> EnumeratedField
arrowRng maxyx@(my,mx) list el@(yx@(y,x),val)
| arrowIsUp val = arrowLtoN (yx,UpL $ countDNOP [getYX' maxyx (y',x) list | y' <- [0..y-1]])
| arrowIsDown val = arrowLtoN (yx,DownL $ countDNOP [getYX' maxyx (y',x) list | y' <- [y+1..my-1]])
| arrowIsLeft val = arrowLtoN (yx,LeftL $ countDNOP [getYX' maxyx (y,x') list | x' <- [0..x-1]])
| arrowIsRight val = arrowLtoN (yx,RightL $ countDNOP [getYX' maxyx (y,x') list | x' <- [x+1..mx-1]])
| otherwise = el
-- Various optimizations. For example [..., LeftN 3, Left, ...] gives [..., LeftN 3, LeftL [3,4], ...]
arrowOptimize :: YXPair -> EnumeratedConflist -> EnumeratedConflist
arrowOptimize maxyx list = if down == list then down else arrowOptimize maxyx down
where
left = arrowLeftOptimize maxyx list []
right = arrowRightOptimize maxyx (reverse left) []
up = arrowUpOptimize maxyx right []
down = arrowDownOptimize maxyx (reverse up) []
arrowLeftOptimize :: YXPair -> EnumeratedConflist -> EnumeratedConflist -> EnumeratedConflist
arrowLeftOptimize maxyx [] acc = reverse acc
arrowLeftOptimize maxyx (el@(yx@(y,x),val):list) acc =
if arrowIsLeftL val || arrowIsLeft val then
arrowLeftOptimize maxyx list ((arrowLtoN(yx,LeftL $ countDNOP [getYX (y,x') acc | x' <- [0..x-1]])):acc)
else arrowLeftOptimize maxyx list (el:acc)
arrowRightOptimize :: YXPair -> EnumeratedConflist -> EnumeratedConflist -> EnumeratedConflist
arrowRightOptimize maxyx [] acc = acc
arrowRightOptimize maxyx@(my,mx) (el@(yx@(y,x),val):list) acc =
if arrowIsRightL val || arrowIsRight val then
arrowRightOptimize maxyx list ((arrowLtoN(yx,RightL $ countDNOP [getYX (y,x') acc | x' <- [x+1..mx-1]])):acc)
else arrowRightOptimize maxyx list (el:acc)
arrowUpOptimize :: YXPair -> EnumeratedConflist -> EnumeratedConflist -> EnumeratedConflist
arrowUpOptimize maxyx [] acc = reverse acc
arrowUpOptimize maxyx (el@(yx@(y,x),val):list) acc =
if arrowIsUpL val || arrowIsUp val then
arrowUpOptimize maxyx list ((arrowLtoN(yx,UpL $ countDNOP [getYX (y',x) acc | y' <- [0..y-1]])):acc)
else arrowUpOptimize maxyx list (el:acc)
arrowDownOptimize :: YXPair -> EnumeratedConflist -> EnumeratedConflist -> EnumeratedConflist
arrowDownOptimize maxyx [] acc = acc
arrowDownOptimize maxyx@(my,mx) (el@(yx@(y,x),val):list) acc =
if arrowIsDownL val || arrowIsDown val then
arrowDownOptimize maxyx list ((arrowLtoN(yx,DownL $ countDNOP [getYX (y',x) acc | y' <- [y+1..my-1]])):acc)
else arrowDownOptimize maxyx list (el:acc)
{- ************************************** DATA OPERATIONS ************************************** -}
arrowAssign :: Field -> Int -> Field
arrowAssign (UpL _) n = UpN n
arrowAssign (RightL _) n = RightN n
arrowAssign (DownL _) n = DownN n
arrowAssign (LeftL _) n = LeftN n
arrowIsUp Up = True
arrowIsUp _ = False
arrowIsUpL (UpL _) = True
arrowIsUpL _ = False
arrowIsUpN (UpN _) = True
arrowIsUpN _ = False
arrowIsDown Down = True
arrowIsDown _ = False
arrowIsDownL (DownL _) = True
arrowIsDownL _ = False
arrowIsDownN (DownN _) = True
arrowIsDownN _ = False
arrowIsRight Right = True
arrowIsRight _ = False
arrowIsRightL (RightL _) = True
arrowIsRightL _ = False
arrowIsRightN (RightN _) = True
arrowIsRightN _ = False
arrowIsLeft Left = True
arrowIsLeft _ = False
arrowIsLeftL (LeftL _) = True
arrowIsLeftL _ = False
arrowIsLeftN (LeftN _) = True
arrowIsLeftN _ = False
arrowSure :: Field -> Bool
arrowSure (UpN _) = True
arrowSure (RightN _) = True
arrowSure (DownN _) = True
arrowSure (LeftN _) = True
arrowSure _ = False
arrowGetValN :: Field -> Maybe Int
arrowGetValN (UpN n) = Just n
arrowGetValN (RightN n) = Just n
arrowGetValN (DownN n) = Just n
arrowGetValN (LeftN n) = Just n
arrowGetValN _ = Nothing
arrowGetValL :: Field -> Maybe [Int]
arrowGetValL (UpL n) = Just n
arrowGetValL (RightL n) = Just n
arrowGetValL (DownL n) = Just n
arrowGetValL (LeftL n) = Just n
arrowGetValL _ = Nothing
{- **************************************** COORDINATES **************************************** -}
-- Convert between (y,x) to n and back
yxton :: YXPair -> YXPair -> Int
yxton (maxy, maxx) (y,x) = y*maxx + x
ntoyx :: YXPair -> Int -> YXPair
ntoyx (maxy, maxx) n = (n `div` maxx, n `mod` maxx)
-- Get n'th Field
getN :: Int -> Conflist -> Field
getN n xs = xs !! n
-- Get (y,x)'th field. Functions using getYX are *SURE* this element exists
getYX :: YXPair -> EnumeratedConflist -> Field
getYX yx ((yx',val):list) | yx == yx' = val
| otherwise = getYX yx list
-- Get all elements with the second coordinate == x
getColumn :: Int -> EnumeratedConflist -> EnumeratedConflist
getColumn x [] = []
getColumn x (el@((_,x'),_):list) | x == x' = el:(getColumn x list)
| otherwise = getColumn x list
-- Optimized getYX used by optimized functions
getYX' :: YXPair -> YXPair -> EnumeratedConflist -> Field
getYX' maxyx yx list = snd $ list !! (yxton maxyx yx)