Declaratieve Talen/oplossingenPalindromen

Een eerste oplossing voor vraag 1

% Warning: Does not generate all solutions.
% 
% Substitutes elements which occur the least in the list.
% The cost is defined as the number of subsitutions, hence
% the length of the list minus the times the most common element occurs.
% Torben Gernaey & Sven Thijssen
allesgelijk(List, Cost, Result) :-
    map_elements(List, UnsortedMap),
    sort(UnsortedMap, SortedLowToHighMap),
    reverse(SortedLowToHighMap, SortedHighToLowMap),
    most_common(SortedHighToLowMap, Times, Element),
    substitute(List, Element, Result),
    length(List, Length),
    Cost is Length - Times.
     

map_elements(List, Map) :-
    map_elements(List, [], Map).
map_elements([], Map, Map).
map_elements([Element|List], Map, Result) :-
    \+ member(pair(_, Element), Map),
    append([pair(1, Element)], Map, NewMap),
    map_elements(List, NewMap, Result).
map_elements([Element|List], Map, Result) :-
    member(pair(_, Element), Map),
    update_element(Element, Map, [], NewMap),
    map_elements(List, NewMap, Result)

update_element(_, [], Result, Result).
update_element(Element, [pair(Value, Key)|Map], Temp, Result) :-
    Element \= Key,
    update_element(Element, Map, [pair(Value, Key)|Temp], Result).
update_element(Element, [pair(Value, Element)|Map], Temp, Result) :-
    NewValue is Value + 1,
    update_element(Element, Map, [pair(NewValue, Element)|Temp], Result). 

most_common([pair(Times,Element)|_], Times, Element).
substitute([], _, []).
% Not necessary to split, since all elements will be the same.
% Other solution:
% substitute([_|List], Element, [Element|Result]) :-
% 	substitute(List, Element, Result).
substitute([X|List], Element, [Element|Result]) :-
    X \= Element,
    substitute(List, Element, Result).
substitute([Element|List], Element, [Element|Result]) :-
    substitute(List, Element, Result). 

Een andere (redelijk lange) oplossing met A* voor vraag 2

--Nick.dewaele (overleg) 31 dec 2017 18:48 (CET)

%===== vraag 1 ======

% waar als Elem het vaakst voorkomende element is in List
mostCommonElement(List, Elem, NumOccurences) :-
    % er zijn snellere manieren om dit te doen, maar dit is niet de essentie
    sort(List, Ls), % verwijdert dubbels
    findall(Count-E, (
        member(E,Ls),
        findall(E, member(E,List), Occurences),
        length(Occurences, Count)
    ), ElemCounts),
    sort(1, @>=, ElemCounts, Sorted),
    Sorted = [MaxNumOcc-_ | _],
    findall(Count-E, (
        member(Count-E, Sorted),
        Count =:= MaxNumOcc
    ), PossibleAnswers),
    member(NumOccurences-Elem, PossibleAnswers).

% In 'allesgelijk' ga je alles behalve 1 element veranderen. Het is uiteraard optimaal
% als dat element het meest voorkomende is. Dus we nemen een herhaling van het vaakst voorkomende element.
allesgelijk(List, Cost, Seq) :-
    mostCommonElement(List, E, NumOcc),
    length(List, Len),
    Cost is Len - NumOcc,
    replicate(Len, E, Seq).

% herhaal iets N keer
replicate(N, Thing, [Thing|Res]) :-
    N > 0,
    Nmin1 is N - 1,
    replicate(Nmin1, Thing, Res).
replicate(0,_,[]).

% ===== vraag 2 =====

% vervang alle voorkomens van een letter in een woord door een andere opgegeven letter
substitute(Word, LetterToReplace, ReplacingLetter, Res, NumReplacements) :-
    substitute(Word, LetterToReplace, ReplacingLetter, 0, Res, NumReplacements).

substitute([Letter|Word], LetterToReplace, ReplacingLetter, AccReplacements, [NewLetter|NewWord], NumReplacements) :-
    (Letter = LetterToReplace ->
        NewLetter = ReplacingLetter,
        NewAcc is AccReplacements + 1
    ;
        NewLetter = Letter,
        NewAcc = AccReplacements
    ),
    substitute(Word, LetterToReplace, ReplacingLetter, NewAcc, NewWord, NumReplacements).
substitute([],_,_,Acc,[],Acc).

isPalindrome(P) :- numUnmatchedPairs(P, 0).

% Geeft het aantal keer dat het i-de en het n-i -de karakter verschillend zijn (met n de lengte van het woord)
numUnmatchedPairs(L, N) :-
    reverse(L, Lrev),
    length(L, Len),
    HalfLen is floor(Len / 2),
    countUnmatched(L, Lrev, HalfLen, 0, N).

countUnmatched([H1|T1], [H2|T2], I, Acc, Res) :-
    I > 0,
    Imin1 is I - 1,
    ( H1 = H2 ->
        NewAcc = Acc
    ;
        NewAcc is Acc + 1
    ),
    countUnmatched(T1, T2, Imin1, NewAcc, Res).
countUnmatched(_,_,0,Acc,Acc).

heuristic(L, H) :- numUnmatchedPairs(L,H).

% voorstelling van een knoop: F_Kost-node(Woord, Letters_die_al_een_andere_letter_vervangen, Laast_vervangen_letter Kost)
aStar([F-node(Word, _, _, Cost) | _], _, Cost, Word) :-
    % we hebben hier een heuristiek die enkel nul wordt bij palindromen
    F =:= Cost,
    !.
aStar([_-node(Word, ReplacingLetters, LastReplaced, G) | Q], Alphabet, ResCost, ResWord) :-
    sort(Word, LettersOfCurrentWord),
    % zoek alle buren.
    % 1) Vervang nooit een letter (zeg b) die al een andere letter (zeg a) vervangt (zeg: b vervangen door c)
    % Dan betaal je twee keer om je a's te vervangen en dat is suboptimaal. Dan zal in een andere tak wel
    % een knoop ontwikkeld worden waar eerst de a's c's worden en dan de b's c's worden
    %
    % 2) Het zou kunnen gebeuren dat je dubbels genereert: bijvoorbeeld met een pad dat
    % eerst a->b en dan c->d vervangt en dan een pad dat c->d en dan a->b doet
    % Om dat te vermijden vervang je een letter nooit als er al een letter is die later in het
    % alfabet komt en al vervangen is
    findall(NeighborF-node(Neighbor, [ReplacingLetter | ReplacingLetters], ReplacedLetter, NewG), (
        % kies een letter die je wilt vervangen
        member(ReplacedLetter, LettersOfCurrentWord),
        \+ member(ReplacedLetter, ReplacingLetters), % zie puntje 1
        appearsAfterIn(ReplacedLetter, LastReplaced, Alphabet), % zie puntje 2

        % kies een letter die de nieuwe vervangt
        member(ReplacingLetter, LettersOfCurrentWord),
        ReplacedLetter \= ReplacingLetter,

        % voer de substitutie uit en bepaal de kost
        substitute(Word, ReplacedLetter, ReplacingLetter, Neighbor, DeltaG),
        NewG is G + DeltaG,
        heuristic(Neighbor, H),
        NeighborF is NewG + H
    ), Neighbors),
    insertAll(Neighbors, Q, NewQ),
    aStar(NewQ, Alphabet, ResCost, ResWord).

insertAll(Nodes, Q, Res) :-
    append(Nodes, Q, Concat),
    sort(1, @=<, Concat, Res).

% waar asa A na B voorkomt in de opgegeven lijst
appearsAfterIn(A,B,[H|T]) :-
    A \= H,
    (B = H -> true; appearsAfterIn(A,B,T)).

palindroom(Word, Cost, Seq) :-
    sort(Word, Alphabet),
    heuristic(Word, H),
    aStar([H-node(Word, [], emptySymbol, 0)], [emptySymbol|Alphabet], Cost, Seq).




Een andere oplossing

--Jelle.de coninck (overleg) 8 jan 2018 20:26 (CET)

De oplossing voor vraag 2 is redelijk elegant maar de code is 50%+ edge case handling ¯\_(ツ)_/¯

% DEEL 1

allesgelijk(Seq1,Kost,Seq0) :-
    findall(N-X,(member(X,Seq1),occurrences(X,Seq1,N)),L),    % zoek het aantal voorkomens van elk element
    max_member(N-_,L),                                        % N = hoogste aantal voorkomens
    member(N-E,L),                                            % E = element met N voorkomens (backtrackt over alle opties)
    length(Seq1,Len),
    Kost is Len - N,
    replicate(E,Len,Seq0).

% replicate(X,N,Out) => Out == [X for _ in range(N)]
replicate(_,0,[]).
replicate(E,N,[E|R]) :- N > 0, M is N - 1, replicate(E,M,R). 

% occurrences(X,L,N) => N == het aantal voorkomens van X in L
occurrences(_,[],0).
occurrences(X,[X|R],N) :-
    !,
    occurrences(X,R,M),
    N is M + 1.
occurrences(X,[_|R],N) :- occurrences(X,R,N).

% DEEL 2

% strategie:
% een palindroom van even lengte is van de vorm L ++ R met reverse(L,R)
% een palindroom van oneven lengte is van de vorm L ++ x ++ R met reverse(L,R) en x één enkel element
% we kunnen de gegeven sequentie opsplitsen in 2 delen van gelijke lengte, L' en R'
% (en eventueel een middelste element x)
% stel we draaien R' om en leggen het element per element naast L'
%   (a) als een paar elementen overeenkomt moeten we niets doen
%   (b) als een paar niet overeenkomt moeten we één van de twee kiezen en het andere vervangen door een kopie van het eerste
%       dan hebben we één letter vervangen dus kost += 1
% het palindroom is dan L' ++ R' (of L' ++ x ++ R')
% de functie match(L',R',Out) geeft alle mogelijke "aangepaste" L', het palindroom is dan Out ++ x ++ (reverse Out)
% de functie palindroom is vooral fuckery om de input op te splitsen als L' ++ x ++ R'
palindroom(Seq1,Kost,Seq2) :-
    length(Seq1,Len),
    HLen is floor(Len / 2),   % Lengte van L' en R'
    HCeil is ceil(Len / 2),   % Index van x
    reverse(Seq1,RSeq1),
    take(HLen,Seq1,S),        % S == L'
    take(HLen,RSeq1,R),       % R == R'
    take(HCeil,Seq1,C),
    append(S,M,C),            % C == [x] of []
    match(S,R,O,Kost),
    reverse(O,RO),
    append(O,M,OM),
    append(OM,RO,Seq2).

% match(L',R',Out,Kost) => for index,elem in enumerate(Out): (elem == L'[index] or elem == R'[index])
match([],[],[],0).
match([S|R1],[S|R2],[S|O],K) :- !,match(R1,R2,O,K).  % geval (a), cut zodat er niet over (b) wordt gebacktrackt
match([S1|R1],[S2|R2],[S|O],K) :-                    % geval (b)
    (S = S1
     ;
     S = S2),
    match(R1,R2,O,K1),
    K is K1 + 1.

% take(N,L,Out) => Out == L[N:]
take(0,_,[]).
take(N,[X|L],[X|R]) :- M is N - 1, take(M,L,R).