Lisp & Prolog Tasks
Это типичные задачи из университетского курса.
Если, что-то надо решить - пишите, помогу если будет время
Отправить задачу
by Petro Protsyk
GNU Prolog - интерпретатор, на котором выполняются примеры на прологе
//Народ! Очень нужна помощь.
//Помогите решить задачку:
//На доске 4х4 расставить 4 слона так, чтобы они все находились
//не под ударом друг друга.
//Буду очень признательна.
(defun el_in (x y lst)
(cond
((NULL lst) 0)
((and (eql (car(car lst)) x) (eql(car(cdr(car lst))) y)) 1 )
( 1 (el_in x y (cdr lst)) )
)
)
(defun el_bit (x y lst)
(cond
((NULL lst) 0)
((and (eql (abs (-(car(car lst)) (car(cdr(car lst))))) (abs(- x y)))) 1)
( 1 (el_bit x y (cdr lst)) )
)
)
(defun find_pos1 (lst_el state)
(cond
( (eql (length lst_el) 4) (print lst_el))
( 1
(setq nx 0)
(setq ny 0)
(loop
(setq nx (+ nx 1))
(loop
(setq ny (+ ny 1))
(cond
((AND (eql (el_in nx ny lst_el) 0) (eql (el_bit nx ny lst_el) 0))
(push nx state)
(push ny state)
(find_pos1 (cons(list nx ny) lst_el) state)
(setq ny (pop state))
(setq nx (pop state))
)
)
((> ny 3) (setq ny 0) NULL)
)
((> nx 3) NULL)
)
)
)
)
(defun solve()
(find_pos1)
)
Волк-Коза-Капуста
Поиск в Ширину
(defun is_in (k lst)
(cond
( (NULL lst) NIL)
( (eql k (car lst)) T)
( 1 (is_in k (cdr lst)) )
)
)
(defun remove (k lst)
(cond
((NULL lst) NIL)
((eql k (car lst)) (remove k (cdr lst)) )
( 1 (cons (car lst) (remove k (cdr lst))) )
)
)
(defun is_ok (lst)
(cond
( (NULL lst) T )
( (is_in 'man lst) T )
( (and (is_in 'goat lst) (is_in 'cabbage lst)) NIL)
( (and (is_in 'wolf lst) (is_in 'goat lst)) NIL)
( 1 T)
)
)
(defun move (k)
(cond
( (eql k 'man)
(cond
((is_in 'man left) (setq left (remove 'man left)) (setq right (cons 'man right))? T)
((is_in 'man right) (setq right (remove 'man right)) (setq left (cons 'man left)) T)
)
)
( (and (is_in k left) (is_in 'man left)) (setq left (remove 'man (remove k left))) (setq right (cons 'man (cons k right))) T )
( (and (is_in k right) (is_in 'man right)) (setq right (remove 'man (remove k right))) (setq left (cons 'man (cons k left))) T )
( 1 NIL)
)
)
(defun perevoz()
(setq p (car way))
(setq way (cdr way))
(setq left (car (cdr p)))
(setq right (car (cddr p)))
(setq k (car p))
(cond ((eql (length right) 4) (print p) (return)))
(cond
( (and (is_ok left) (is_ok right))
(cond ((and (neql (car(last k)) 'goat) (move 'goat)) (setq way (append way (list (list (append k (list 'goat)) left right)))) (move 'goat)))
(cond ((and (neql (car(last k)) 'wolf) (move 'wolf)) (setq way (append way (list (list (append k (list 'wolf)) left right)))) (move 'wolf)))
(cond ((and (neql (car(last k)) 'cabbage) (move 'cabbage)) (setq way (append way (list (list (append k (list 'cabbage)) left right))))(move 'cabbage)))
(cond ((and (neql (car(last k)) 'man) (move 'man)) (setq way (append way (list (list (append k (list 'man)) left right))))(move 'man)))
)
)
(perevoz)
)
(defun solve ()
(setq way nil)
(setq left '(goat cabbage wolf man))
(setq right NIL)
(move 'goat)
(setq way (append way (list (list (list 'goat) left right))))
(setq left '(goat cabbage wolf man))
(setq right NIL)
(move 'wolf)
(setq way (append way (list (list (list 'wolf) left right))))
(setq left '(goat cabbage wolf man))
(setq right NIL)
(move 'cabbage)
(setq way (append way (list (list (list 'cabbage) left right))))
(setq right NIL)
(setq left NIL)
(perevoz)
)
Задание 1. Операции со списками. Создать функцию на
языке Лисп, которая выполняет следующие действия:
8.Перегруппирует элементы заданного списка так, чтобы
одинаковые элементы, если они есть в списке, стояли
все подряд.
(defun is_in(el spis)
(cond
((null spis) nil )
((eql el (car spis)) T)
( nul (is_in el (cdr spis)) )
)
)
(defun remove_first(el spis)
(cond
((null spis) nil )
((eql el (car spis)) (cdr spis))
( nul (cons (car spis) ( remove_first el (cdr spis) ) ) )
)
)
(defun l8(spis)
(cond
((null spis) nil )
((is_in (car spis) (cdr spis)) (cons (car spis) (cons (car spis) (l8 (remove_first (car spis) (cdr spis))))))
(nul (cons (car spis) (l8 (cdr spis))) )
)
)
запускать так:
(l8 '(1 2 1 3 2 5 7 1))
Задание 2. Создать на языке Лисп:
8.Функцию, упорядочивающую список, заданный в качестве
ее первого аргумента, переставляя его элементы в той
последовательности, в какой они встречаются в списке,
являющемся значением второго аргумента.
(defun is_in(el spis)
(cond
((null spis) nil )
((eql el (car spis)) T)
( nul (is_in el (cdr spis)) )
)
)
(defun remove_first(el spis)
(cond
((null spis) nil )
((eql el (car spis)) (cdr spis))
( nul (cons (car spis) ( remove_first el (cdr spis) ) ) )
)
)
(defun l8_1(spis spis1)
(cond
((null spis) nil )
((null spis1) spis)
((is_in (car spis1) spis) (cons (car spis1) (l8_1 (remove_first (car spis1) spis) spis1)))
(nul (l8_1 spis (cdr spis1) ) )
)
)
Задача Шi-1 (+)
На мовi програмування Лiсп написати програму, що друкує всi перестановки чисел вiд 1 до n.
(DEFUN isin(k lst)
(COND ((NULL lst) NIL)
((eq (car lst) k) T)
(1 (isin k (cdr lst)))
)
)
(DEFUN perest(n k lst)
(COND ((> k n) (PRINT lst))
(1 (SET 'i '1)
(LOOP
(COND
((> i n) (RETURN NIL))
( (COND
((isin i lst) (set 'i (+ i '1)))
(1 (PUSH i stk) (perest n (+ k '1) (CONS i lst)) (set 'i (+ (POP stk) '1)))
)
)
)
)
)
)
)
(DEFUN makeperest(n)
(SET 'stk NIL)
(perest n 1 NIL)
)
Задача Шi-2 (+)
На мовi програмування Лiсп написати функцiю обчислення значення многочлена в точцi за схемою Горнера.
Рn = (...( ( a0x + a1)x + а2)x + ... + аn-1)x + аn.
Схема Горнера: Р0 = a0; p1 = Р0 • x + a1 = a0x + a1; p2 = Р1 • x + a2 = a0x2 + a1x + a2; ….
(DEFUN GORNREC (lst x)
((NULL (CDR lst)) (CAR lst))
(GORNREC (CONS (+ (* (CAR lst) x) (CADR lst)) (CDDR lst)) x)
)
(COMMENT koeficients set in reverse order 4*x^0+ 2*x^1+ 1*x^2)
(SETQ koef '(1 2 4))
(SETQ res (GORNREC koef 2))
Задача Шi-3 (+)
На мовi програмування Лiсп написати функцiю REVERSELIST – обертання списку з пiдсписками.
(DEFUN REVERSE(lst)
(COND ((NULL lst) NIL)
((ATOM (CAR LST)) (APPEND (REVERSE (CDR lst)) (LIST(CAR LST))) )
(1 (APPEND (REVERSE (CDR lst)) (LIST (REVERSE (CAR LST)))) )
)
)
Задача Шi-4 (+)
На мовi програмування Лiсп написати функцiю швидкого сортування для вхiдного списку чисел.
(DEFUN FIRST_EL(n lst)
(COND (( < = n 0) NIL)
((NULL lst) NIL)
(1 (CONS (CAR lst) (FIRST_EL (- n '1) (CDR LST))))
)
)
(DEFUN LAST_EL(n lst)
(COND ((<= n 0) LST)
((NULL lst) NIL)
(1 (LAST_EL (- n '1) (CDR LST)))
)
)
(DEFUN SPLIT(lst)
(SET 'fi (FIRST_EL (/ (LENGTH lst) 2) lst))
(SET 'li (LAST_EL (LENGTH fi) lst))
(LIST fi li)
)
(DEFUN MERGE(lst1 lst2)
(COND ((NULL lst1) lst2)
((NULL lst2) lst1)
((> (CAR lst1) (CAR lst2)) (CONS (CAR lst2) (MERGE lst1 (CDR lst2))))
(1 (CONS (CAR lst1) (MERGE (CDR lst1) lst2)))
)
)
(DEFUN SORT(LST)
(COND ( (eq (LENGTH (CAR (SPLIT LST))) 1) (MERGE (CAR (SPLIT LST)) (CAR(CDR (SPLIT LST)))))
( 1 (MERGE (SORT (CAR (SPLIT LST))) (SORT(CAR (CDR (SPLIT LST))))))
)
)
Задача Шi-5 (+)
На мовi програмування Лiсп написати функцiю (PRNUM2 num), яка перетворює десяткове представлення числа num у двiйкове.
(DEFUN DecToBin(n lst)
(COND ((> n '1) (DecToBin (/ (- n (MOD n '2)) 2) (CONS (MOD n '2) lst)) )
(1 (CONS n lst))
)
)
Задача Шi-6 (+)
Написати на Пролозi програму об’єднання двох вiдсортованих спискiв в один.
Наприклад: (2, 3, 6, 8) та (1, 4, 5, 7, 10) -> (1, 2, 3, 4, 5 ,6 ,7, 8, 10).
conct([],L,L).
conct(L,[],L).
conct([A|B],[C|D],[A|L]):- A < C, conct(B,[C|D],L).
conct([A|B],[C|D],[C|L]):- C=< A, conct([A|B],D,L).
Задача Шi-7 (+)
Написати на Пролозi програму, яка друкує всi пiдмножини заданої множини.
iдея розв’язку – грунтується на спiввiдношеннi
Boolean(X) = Boolean(X\{y}) U {y} U { (S U {y}) | S множина з Boolean(X\{y})}.
Побудову множини { (S U {y}) | S множина з Boolean(X\{y})} здiйснює функцiя comb. Функцiя обчислює вищенаведене рекурентне спiввiдношення!!!!!
comb(A,[],[]).
comb(A,[B|C],[B,[A|B]|E]):-comb(A,C,E).
bol([],[[]]).
bol([A|B],S):-bol(B,S1),comb(A,S1,S).
Напишите функцию, которая сортирует список чисел, используя алгоритм простого выбора (Lisp).
(defun sort1(s)
( if (null s) nil
(let((c(min1 x s))(r (sort1(remove1 c s )))))
(t(cons(c r))))
Определите функцию (f s), результатом которой является список, получающийся из списка списков s после удаления всех подсписков, содержащих числа (Lisp).
(defun f(s)
( if (null s) nil
(let((c(first s))(r(rest s))))
(cond((and(numberp x)(member x c))(remove c)))
(t (cons(f(c)(f(r))))))
Напишите функцию на Lisp, осуществляющую циклическую перестановку
элементов в списке, т.е. (f g h j) -> (g h j f).
(defun k(x)
(if(null x) nil
((null(rest x)) nil
(let((c(first x))(r (rest x))))
(t( append1 (r c)))))
Напишите функцию (Lisp), которая из данного одноуровнего списка строит список списков его элементов, например, (a b) -> ((a) (b)).
(defun f(s)
(if (null s) nil
(let(r(rest s)))
(t(cons(list(first s)) (f(r))))))
Определите функцию (Lisp), зависящую от двух аргументов u и v, являющихся списками, которая вычисляет список всех элементов u, не содержащихся в v.
(defun f(v u)
(if(null u) nil
(let((c(first u))(r(rest u))))
(cond((and(atom c)(equal v c)) (f v r))
((atom c)( cons c (f v r)))
(t(cons(f v c)(f v r))))))
% 4.04.2005 Процик П П
% Шашки на Прологе
% КНУ ф. Кибернетики
% использовние:
%
% ?-consult(['c.pro']).
% ?-begin.
%
% Правила: шашки могут ходить и вперёд и назад
% дамок в игре нет
% Версия демонстрационная!
% Стратегия выбора ходов №1 - максимизация вариантов.
% --------------------- Display Board Routines ----------------------------------------------------%
display_board:-display(' '),display_line(0,1,2),nl,display_lines(1).
check_fig(I,J,[[X1,ROW,COL]|Y]):-I=COL,J=ROW,!.
check_fig(I,J,[[X1,ROW,COL]|Y]):-check_fig(I,J,Y).
check_figure(I,J,K,C):-brd(b,PL1,PL2),check_fig(I,J,PL1),C='X',!.
check_figure(I,J,K,C):-brd(b,PL1,PL2),check_fig(I,J,PL2),C='Y',!.
check_figure(I,J,K,C):-K=0,C=' '.
check_figure(I,J,K,C):-C='#'.
display_line(I,J,K):-J<9,K=1,
check_figure(I,J,K,C),
display('['),display(C),display(']'),
J1 is J+1,!,display_line(I,J1,0).
display_line(I,J,K):-J<9,K=0,
check_figure(I,J,K,C),
display('['),display(C),display(']'),
J1 is J+1,!,display_line(I,J1,1).
display_line(I,J,K):-J<9,K=2,display(' '),display(J),display(' '),J1 is J+1,!, display_line(I,J1,2).
display_line(I,J,_):-J=9,!.
display_lines(I):-I<9,I1 is I+1,display(I),K is I mod 2,display_line(I,1,K),nl,display_lines(I1),!.
display_lines(I).
%--------------------------------------------------------------------------------------------------%
% --------------------- Game Playing Routines (Interface,Initial States)--------------------------%
:- op(1200,xfx,[-->]).
set_brd(X) :-retract(brd(_,_,_)),asserta(X).
set_brd(X) :-asserta(X).
parse_input(([R1,C1] --> [R2,C2])):-!,display(R1),display(':'),display(C1),
display(' move to '),
display(R2),display(':'),display(C2),nl.
parse_input(_):-display('Input error!'),!.
make_input(X):-!,display('input move in form [R,C] --> [R,C].'),nl,read(X).
% Two players game:
game_play2:-display_board,
brd(b,PL1,PL2),
plr_move(PL1,PL2),
brd(b,PLL,PLM),
retract(brd(b,PLL,PLM)),
NB = brd(b,PLM,PLL),
assertz(NB),
game_play2.
% Two player vs Mashine:
game_play1:-display_board,
brd(b,PL1,PL2),
plr_move(PL1,PL2),
brd(b,PLL,PLM),
retract(brd(b,PLL,PLM)),
NB = brd(b,PLM,PLL),
assertz(NB),
display_board,
comp_move(PLM,PLL),
brd(b,PLL1,PLM1),
retract(brd(b,PLL1,PLM1)),
NB1 = brd(b,PLM1,PLL1),
assertz(NB1),
game_play1.
begin:- set_brd(brd(b,[[p,1,1], [p,3,1], [p,5,1], [p,7,1],
[p,2,2], [p,4,2], [p,6,2], [p,8,2],
[p,1,3], [p,3,3], [p,5,3], [p,7,3]],
[[p,2,8], [p,4,8], [p,6,8], [p,8,8],
[p,1,7], [p,3,7], [p,5,7], [p,7,7],
[p,2,6], [p,4,6], [p,6,6], [p,8,6]]
)
),
display('Light Checkers v0.01'),nl,
display('by Piter Protsyk, April 2005'),nl,
display('KNU faculty of Cybernetics'),nl,nl,
display('Input (game_play1) : Player vs Computer '),nl,
display(' (game_play2) : Player vs Player '),nl,
read(Game_play),
Game_play.
%--------------------------------------------------------------------------------------------------%
% --------------------- Human moving and Computer Logic -------------------------------------------%
% check whether board cell is empty
empty_cell(Row,Col,B):-!,brd(B,PL1,PL2),empty_cell(Row,Col,B,PL1),empty_cell(Row,Col,B,PL2).
empty_cell(Row,Col,B,[[p,R,C]|Y]):- [Row,Col] \= [R,C],!, empty_cell(Row,Col,B,Y).
empty_cell(Row,Col,B,[[p,R,C]|Y]):- [Row,Col] = [R,C],!, fail.
empty_cell(_,_,_,_).
% Check wheter this move is valid
valid_move(R1,C1,R2,C2):-R2 is R1+1, C2 is C1+1,R2<9,C2<9,R2>0,C2>0,!.
valid_move(R1,C1,R2,C2):-R2 is R1+1, C2 is C1-1,R2<9,C2<9,R2>0,C2>0,!.
valid_move(R1,C1,R2,C2):-R2 is R1-1, C2 is C1+1,R2<9,C2<9,R2>0,C2>0,!.
valid_move(R1,C1,R2,C2):-R2 is R1-1, C2 is C1-1,R2<9,C2<9,R2>0,C2>0,!.
% Check wheter this bit is valid
valid_bit(R1,C1,R2,C2,R3,C3):-R2 is R1+2, C2 is C1+2,R3 is R1+1, C3 is C1+1,R2<9,C2<9,R2>0,C2>0,!.
valid_bit(R1,C1,R2,C2,R3,C3):-R2 is R1+2, C2 is C1-2,R3 is R1+1, C3 is C1-1,R2<9,C2<9,R2>0,C2>0,!.
valid_bit(R1,C1,R2,C2,R3,C3):-R2 is R1-2, C2 is C1+2,R3 is R1-1, C3 is C1+1,R2<9,C2<9,R2>0,C2>0,!.
valid_bit(R1,C1,R2,C2,R3,C3):-R2 is R1-2, C2 is C1-2,R3 is R1-1, C3 is C1-1,R2<9,C2<9,R2>0,C2>0,!.
not(X):-X,!,fail.
not(X).
check_move(([R1,C1] --> [R2,C2]),B,PL1,PL2):-empty_cell(R2,C2,B),not(empty_cell(R1,C1,PL1)),
valid_move(R1,C1,R2,C2).
check_bit(([R1,C1] --> [R2,C2]),B,PL1,PL2,R3,C3):-empty_cell(R2,C2,B),not(empty_cell(R1,C1,PL1)),
valid_bit(R1,C1,R2,C2,R3,C3),not(empty_cell(R3,C3,PL2)).
%Move check
make_move(([R1,C1] --> [R2,C2]),B,PL1,PL2):-check_move(([R1,C1] --> [R2,C2]),B,PL1,PL2),
delete(PL1,[p,R1,C1],PPL1),
append(PPL1,[[p,R2,C2]],PNL1),
retract(brd(B,PL1,PL2)),
NB = brd(B,PNL1,PL2),
assertz(NB).
%Bit a check
make_move(([R1,C1] --> [R2,C2]),B,PL1,PL2):-check_bit(([R1,C1] --> [R2,C2]),B,PL1,PL2,R3,C3),
delete(PL1,[p,R1,C1],PPL1),
delete(PL2,[p,R3,C3],PPL2),
append(PPL1,[[p,R2,C2]],PNL1),
retract(brd(B,PL1,PL2)),
NB = brd(B,PNL1,PPL2),
assertz(NB).
chck_fin.
plr_move(PL1,PL2):- make_input(X),
parse_input(X),
make_move(X,b,PL1,PL2),
chck_fin,!.
comp_move(PL1,PL2):- assertz(move_cost([0,0,0,0,0])),
generate_move(PL1,PL2,b),
retract(move_cost([X,R1,C1,R2,C2])),
make_move(([R1,C1]-->[R2,C2]),b,PL1,PL2),!.
%All valid moves
v_m(B,R1,C1,R2,C2,PL1,PL2):-R2 is R1+1, C2 is C1+1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)).
v_m(B,R1,C1,R2,C2,PL1,PL2):-R2 is R1+1, C2 is C1-1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)).
v_m(B,R1,C1,R2,C2,PL1,PL2):-R2 is R1-1, C2 is C1+1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)).
v_m(B,R1,C1,R2,C2,PL1,PL2):-R2 is R1-1, C2 is C1-1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)).
%All valid bits
v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2):-R2 is R1+2, C2 is C1+2,R3 is R1+1, C3 is C1+1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)),not(empty_cell(R3,C3,B,PL2)).
v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2):-R2 is R1+2, C2 is C1-2,R3 is R1+1, C3 is C1-1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)),not(empty_cell(R3,C3,B,PL2)).
v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2):-R2 is R1-2, C2 is C1+2,R3 is R1-1, C3 is C1+1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)),not(empty_cell(R3,C3,B,PL2)).
v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2):-R2 is R1-2, C2 is C1-2,R3 is R1-1, C3 is C1-1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)),not(empty_cell(R3,C3,B,PL2)).
%Generates all possible moves
generate_move([[p,R1,C1]|Y],PL2,B):-brd(B,PL1,PL2),
findall((R1,C1,R2,C2),v_m(B,R1,C1,R2,C2,PL1,PL2),VM),
findall((R1,C1,R2,C2,R3,C3),v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2),VB),
% write(VM),
% write(VB),
% nl,
analyze_move(VM,VB),
generate_move(Y,PL2,B),!.
generate_move(_,_,_).
%Calculate cost function
gen_move_lst([[p,R1,C1]|Y],PL2,B,[(VM,VB,[p,R1,C1])|L]):-
brd(B,PL1,PL2),
findall((R1,C1,R2,C2),v_m(B,R1,C1,R2,C2,PL1,PL2),VM),
findall((R1,C1,R2,C2,R3,C3),v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2),VB),
gen_move_lst(Y,PL2,B,L),!.
gen_move_lst(_,_,_,[]).
max([X|X1],[Y|Y1],Z):- X>Y,Z=[X|X1],!.
max(X,Y,Z):- Z = Y,!.
calc_cost(B,R):-brd(B,PL1,PL2),
gen_move_lst(PL1,PL2,B,L),
length(L,R).
%Analyze all moves and select best.
analyze_move(A,[(R1,C1,R2,C2,_,_)|Y]):- brd(b,PL1,PL2),
NB =brd(cmp,PL1,PL2),
assertz(NB),
make_move(([R1,C1] --> [R2,C2]),cmp,PL1,PL2),
calc_cost(cmp,REZ),
retract(brd(cmp,_,_)),
retract(move_cost(Old_cost)),
max([REZ,R1,C1,R2,C2],Old_cost,New_cost),
NMV = move_cost(New_cost),
assertz(NMV),
analyze_move(A,Y),!.
analyze_move([(R1,C1,R2,C2)|Y],[]):- brd(b,PL1,PL2),
NB = brd(cmp,PL1,PL2),
assertz(NB),
make_move(([R1,C1] --> [R2,C2]),cmp,PL1,PL2),
calc_cost(cmp,REZ),
retract(brd(cmp,_,_)),
retract(move_cost(Old_cost)),
max([REZ,R1,C1,R2,C2],Old_cost,New_cost),
NMV = move_cost(New_cost),
assertz(NMV),
analyze_move(Y,[]),!.
analyze_move([],[]).
% 4.04.2005 Процик П П
% Шашки на Прологе
% КНУ ф. Кибернетики
% использовние:
%
% ?-consult(['c.pro']).
% ?-begin.
%
% Правила: шашки могут ходить и вперёд и назад
% дамок в игре нет
% Версия демонстрационная!
% Стратегия №2 Отношения взвешенных весов противников
% --------------------- Display Board Routines ----------------------------------------------------%
display_board:-display(' '),display_line(0,1,2),nl,display_lines(1).
check_fig(I,J,[[X1,ROW,COL]|Y]):-I=COL,J=ROW,!.
check_fig(I,J,[[X1,ROW,COL]|Y]):-check_fig(I,J,Y).
check_figure(I,J,K,C):-brd(b,PL1,PL2),check_fig(I,J,PL1),C='X',!.
check_figure(I,J,K,C):-brd(b,PL1,PL2),check_fig(I,J,PL2),C='0',!.
check_figure(I,J,K,C):-K=0,C=' '.
check_figure(I,J,K,C):-C=' '.
display_line(I,J,K):-J<9,K=1,
check_figure(I,J,K,C),
display('['),display(C),display(']'),
J1 is J+1,!,display_line(I,J1,0).
display_line(I,J,K):-J<9,K=0,
check_figure(I,J,K,C),
display('['),display(C),display(']'),
J1 is J+1,!,display_line(I,J1,1).
display_line(I,J,K):-J<9,K=2,display(' '),display(J),display(' '),J1 is J+1,!, display_line(I,J1,2).
display_line(I,J,_):-J=9,!.
display_lines(I):-I<9,I1 is I+1,display(I),K is I mod 2,display_line(I,1,K),nl,display_lines(I1),!.
display_lines(I).
%--------------------------------------------------------------------------------------------------%
% --------------------- Game Playing Routines (Interface,Initial States)--------------------------%
:- op(1200,xfx,[-->]).
set_brd(X) :-retract(brd(_,_,_)),asserta(X).
set_brd(X) :-asserta(X).
parse_input(([R1,C1] --> [R2,C2])):-!,display(R1),display(':'),display(C1),
display(' move to '),
display(R2),display(':'),display(C2),nl.
parse_input(_):-display('Input error!'),!.
make_input(X):-!,display('input move in form [R,C] --> [R,C].'),nl,read(X).
% Two players game:
game_play2:-display_board,
brd(b,PL1,PL2),
plr_move(PL1,PL2),
brd(b,PLL,PLM),
retract(brd(b,PLL,PLM)),
NB = brd(b,PLM,PLL),
assertz(NB),
game_play2.
% Two player vs Mashine:
game_play1:-display('----============== TURN ================----'),nl,
display_board,
brd(b,PL1,PL2),
plr_move(PL1,PL2),
brd(b,PLL,PLM),
retract(brd(b,PLL,PLM)),
NB = brd(b,PLM,PLL),
assertz(NB),
display_board,
comp_move(PLM,PLL),
brd(b,PLL1,PLM1),
retract(brd(b,PLL1,PLM1)),
NB1 = brd(b,PLM1,PLL1),
assertz(NB1),
game_play1.
begin:- set_brd(brd(b,[[p,1,1], [p,3,1], [p,5,1], [p,7,1],
[p,2,2], [p,4,2], [p,6,2], [p,8,2],
[p,1,3], [p,3,3], [p,5,3], [p,7,3]],
[[p,2,8], [p,4,8], [p,6,8], [p,8,8],
[p,1,7], [p,3,7], [p,5,7], [p,7,7],
[p,2,6], [p,4,6], [p,6,6], [p,8,6]]
)
),
display('Light Checkers v0.01'),nl,
display('by Piter Protsyk, April 2005'),nl,
display('KNU faculty of Cybernetics'),nl,nl,
display('Input (game_play1) : Player vs Computer '),nl,
display(' (game_play2) : Player vs Player '),nl,
read(Game_play),
Game_play.
%--------------------------------------------------------------------------------------------------%
% --------------------- Human moving and Computer Logic -------------------------------------------%
% check whether board cell is empty
empty_cell(Row,Col,B):-!,brd(B,PL1,PL2),empty_cell(Row,Col,B,PL1),empty_cell(Row,Col,B,PL2).
empty_cell(Row,Col,B,[[p,R,C]|Y]):- [Row,Col] \= [R,C],!, empty_cell(Row,Col,B,Y).
empty_cell(Row,Col,B,[[p,R,C]|Y]):- [Row,Col] = [R,C],!, fail.
empty_cell(_,_,_,_).
% Check wheter this move is valid
valid_move(R1,C1,R2,C2):-R2 is R1+1, C2 is C1+1,R2<9,C2<9,R2>0,C2>0,!.
valid_move(R1,C1,R2,C2):-R2 is R1+1, C2 is C1-1,R2<9,C2<9,R2>0,C2>0,!.
valid_move(R1,C1,R2,C2):-R2 is R1-1, C2 is C1+1,R2<9,C2<9,R2>0,C2>0,!.
valid_move(R1,C1,R2,C2):-R2 is R1-1, C2 is C1-1,R2<9,C2<9,R2>0,C2>0,!.
% Check wheter this bit is valid
valid_bit(R1,C1,R2,C2,R3,C3):-R2 is R1+2, C2 is C1+2,R3 is R1+1, C3 is C1+1,R2<9,C2<9,R2>0,C2>0,!.
valid_bit(R1,C1,R2,C2,R3,C3):-R2 is R1+2, C2 is C1-2,R3 is R1+1, C3 is C1-1,R2<9,C2<9,R2>0,C2>0,!.
valid_bit(R1,C1,R2,C2,R3,C3):-R2 is R1-2, C2 is C1+2,R3 is R1-1, C3 is C1+1,R2<9,C2<9,R2>0,C2>0,!.
valid_bit(R1,C1,R2,C2,R3,C3):-R2 is R1-2, C2 is C1-2,R3 is R1-1, C3 is C1-1,R2<9,C2<9,R2>0,C2>0,!.
not(X):-X,!,fail.
not(X).
check_move(([R1,C1] --> [R2,C2]),B,PL1,PL2):-empty_cell(R2,C2,B),not(empty_cell(R1,C1,PL1)),
valid_move(R1,C1,R2,C2).
check_bit(([R1,C1] --> [R2,C2]),B,PL1,PL2,R3,C3):-empty_cell(R2,C2,B),not(empty_cell(R1,C1,PL1)),
valid_bit(R1,C1,R2,C2,R3,C3),not(empty_cell(R3,C3,PL2)).
%Move check
make_move(([R1,C1] --> [R2,C2]),B,PL1,PL2):-check_move(([R1,C1] --> [R2,C2]),B,PL1,PL2),
delete(PL1,[p,R1,C1],PPL1),
append(PPL1,[[p,R2,C2]],PNL1),
retract(brd(B,PL1,PL2)),
NB = brd(B,PNL1,PL2),
assertz(NB).
%Bit a check
make_move(([R1,C1] --> [R2,C2]),B,PL1,PL2):-check_bit(([R1,C1] --> [R2,C2]),B,PL1,PL2,R3,C3),
delete(PL1,[p,R1,C1],PPL1),
delete(PL2,[p,R3,C3],PPL2),
append(PPL1,[[p,R2,C2]],PNL1),
retract(brd(B,PL1,PL2)),
NB = brd(B,PNL1,PPL2),
assertz(NB).
chck_fin.
plr_move(PL1,PL2):- make_input(X),
parse_input(X),
make_move(X,b,PL1,PL2),
chck_fin,!.
comp_move(PL1,PL2):- assertz(move_cost([0,0,0,0,0])),
generate_move(PL1,PL2,b),
retract(move_cost([X,R1,C1,R2,C2])),
nl,display('---------------'),nl,
display('Computer moves:'),
write(([R1,C1]-->[R2,C2])),nl,nl,
make_move(([R1,C1]-->[R2,C2]),b,PL1,PL2),!.
%All valid moves
v_m(B,R1,C1,R2,C2,PL1,PL2):-R2 is R1+1, C2 is C1+1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)).
v_m(B,R1,C1,R2,C2,PL1,PL2):-R2 is R1+1, C2 is C1-1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)).
v_m(B,R1,C1,R2,C2,PL1,PL2):-R2 is R1-1, C2 is C1+1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)).
v_m(B,R1,C1,R2,C2,PL1,PL2):-R2 is R1-1, C2 is C1-1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)).
%All valid bits
v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2):-R2 is R1+2, C2 is C1+2,R3 is R1+1, C3 is C1+1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)),not(empty_cell(R3,C3,B,PL2)).
v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2):-R2 is R1+2, C2 is C1-2,R3 is R1+1, C3 is C1-1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)),not(empty_cell(R3,C3,B,PL2)).
v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2):-R2 is R1-2, C2 is C1+2,R3 is R1-1, C3 is C1+1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)),not(empty_cell(R3,C3,B,PL2)).
v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2):-R2 is R1-2, C2 is C1-2,R3 is R1-1, C3 is C1-1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)),not(empty_cell(R3,C3,B,PL2)).
%Generates all possible moves
generate_move([[p,R1,C1]|Y],PL2,B):-brd(B,PL1,PL2),
findall((R1,C1,R2,C2),v_m(B,R1,C1,R2,C2,PL1,PL2),VM),
findall((R1,C1,R2,C2,R3,C3),v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2),VB),
% write(VM),
% write(VB),
% nl,
analyze_move(VM,VB),
generate_move(Y,PL2,B),!.
generate_move(_,_,_).
%Calculate cost function
gen_move_lst([[p,R1,C1]|Y],PL1,PL2,B,[(VM,VB,[p,R1,C1])|L]):-
findall((R1,C1,R2,C2),v_m(B,R1,C1,R2,C2,PL1,PL2),VM),
findall((R1,C1,R2,C2,R3,C3),v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2),VB),
gen_move_lst(Y,PL1,PL2,B,L),!.
gen_move_lst(_,_,_,_,[]).
max([X|X1],[Y|Y1],Z):- X>Y,Z=[X|X1],!.
max(X,Y,Z):- Z = Y,!.
calc_cost(B,R):-brd(B,PL1,PL2),
gen_move_lst(PL1,PL1,PL2,B,L),
gen_move_lst(PL2,PL2,PL1,B,L1),
weight(L,Rc1),
weight(L1,Rc2),
R is Rc1 / Rc2.
weight([(VM,VB,_)|Y],R):-length(VM,Rc1),
length(VB,Rc2),
weight(Y,R1),
R is R1 + Rc1 + 2*Rc2.
weight([],0).
%length(L,R).
%Analyze all moves and select best.
analyze_move(A,[(R1,C1,R2,C2,_,_)|Y]):- brd(b,PL1,PL2),
NB =brd(cmp,PL1,PL2),
assertz(NB),
make_move(([R1,C1] --> [R2,C2]),cmp,PL1,PL2),
calc_cost(cmp,REZ),
retract(brd(cmp,_,_)),
retract(move_cost(Old_cost)),
max([REZ,R1,C1,R2,C2],Old_cost,New_cost),
NMV = move_cost(New_cost),
assertz(NMV),
analyze_move(A,Y),!.
analyze_move([(R1,C1,R2,C2)|Y],[]):- brd(b,PL1,PL2),
NB = brd(cmp,PL1,PL2),
assertz(NB),
make_move(([R1,C1] --> [R2,C2]),cmp,PL1,PL2),
calc_cost(cmp,REZ),
retract(brd(cmp,_,_)),
retract(move_cost(Old_cost)),
max([REZ,R1,C1,R2,C2],Old_cost,New_cost),
NMV = move_cost(New_cost),
assertz(NMV),
analyze_move(Y,[]),!.
analyze_move([],[]).
% 4.04.2005 Процик П П
% Шашки на Прологе
% КНУ ф. Кибернетики
% использовние:
%
% ?-consult(['c.pro']).
% ?-begin.
%
% Правила: шашки могут ходить и вперёд и назад
% дамок в игре нет
% Версия демонстрационная!
% Стратегия №3 Отношения взвешенных весов противников
% --------------------- Display Board Routines ----------------------------------------------------%
display_board:-display(' '),display_line(0,1,2),nl,display_lines(1).
check_fig(I,J,[[X1,ROW,COL]|Y]):-I=COL,J=ROW,!.
check_fig(I,J,[[X1,ROW,COL]|Y]):-check_fig(I,J,Y).
check_figure(I,J,K,C):-brd(b,PL1,PL2),check_fig(I,J,PL1),C='X',!.
check_figure(I,J,K,C):-brd(b,PL1,PL2),check_fig(I,J,PL2),C='0',!.
check_figure(I,J,K,C):-K=0,C=' '.
check_figure(I,J,K,C):-C=' '.
display_line(I,J,K):-J<9,K=1,
check_figure(I,J,K,C),
display('['),display(C),display(']'),
J1 is J+1,!,display_line(I,J1,0).
display_line(I,J,K):-J<9,K=0,
check_figure(I,J,K,C),
display('['),display(C),display(']'),
J1 is J+1,!,display_line(I,J1,1).
display_line(I,J,K):-J<9,K=2,display(' '),display(J),display(' '),J1 is J+1,!, display_line(I,J1,2).
display_line(I,J,_):-J=9,!.
display_lines(I):-I<9,I1 is I+1,display(I),K is I mod 2,display_line(I,1,K),nl,display_lines(I1),!.
display_lines(I).
%--------------------------------------------------------------------------------------------------%
% --------------------- Game Playing Routines (Interface,Initial States)--------------------------%
:- op(1200,xfx,[-->]).
set_brd(X) :-retract(brd(_,_,_)),asserta(X).
set_brd(X) :-asserta(X).
parse_input(([R1,C1] --> [R2,C2])):-!,display(R1),display(':'),display(C1),
display(' move to '),
display(R2),display(':'),display(C2),nl.
parse_input(_):-display('Input error!'),!.
make_input(X):-!,display('input move in form [R,C] --> [R,C].'),nl,read(X).
% Two players game:
game_play2:-display_board,
brd(b,PL1,PL2),
plr_move(PL1,PL2),
brd(b,PLL,PLM),
retract(brd(b,PLL,PLM)),
NB = brd(b,PLM,PLL),
assertz(NB),
game_play2.
% Two player vs Mashine:
game_play1:-display('----============== TURN ================----'),nl,
display_board,
brd(b,PL1,PL2),
plr_move(PL1,PL2),
brd(b,PLL,PLM),
retract(brd(b,PLL,PLM)),
NB = brd(b,PLM,PLL),
assertz(NB),
display_board,
comp_move(PLM,PLL),
brd(b,PLL1,PLM1),
retract(brd(b,PLL1,PLM1)),
NB1 = brd(b,PLM1,PLL1),
assertz(NB1),
game_play1.
begin:- set_brd(brd(b,[[p,1,1], [p,3,1], [p,5,1], [p,7,1],
[p,2,2], [p,4,2], [p,6,2], [p,8,2],
[p,1,3], [p,3,3], [p,5,3], [p,7,3]],
[[p,2,8], [p,4,8], [p,6,8], [p,8,8],
[p,1,7], [p,3,7], [p,5,7], [p,7,7],
[p,2,6], [p,4,6], [p,6,6], [p,8,6]]
)
),
display('Light Checkers v0.01'),nl,
display('by Piter Protsyk, April 2005'),nl,
display('KNU faculty of Cybernetics'),nl,nl,
display('Input (game_play1) : Player vs Computer '),nl,
display(' (game_play2) : Player vs Player '),nl,
read(Game_play),
Game_play.
%--------------------------------------------------------------------------------------------------%
% --------------------- Human moving and Computer Logic -------------------------------------------%
% check whether board cell is empty
empty_cell(Row,Col,B):-!,brd(B,PL1,PL2),empty_cell(Row,Col,B,PL1),empty_cell(Row,Col,B,PL2).
empty_cell(Row,Col,B,[[p,R,C]|Y]):- [Row,Col] \= [R,C],!, empty_cell(Row,Col,B,Y).
empty_cell(Row,Col,B,[[p,R,C]|Y]):- [Row,Col] = [R,C],!, fail.
empty_cell(_,_,_,_).
% Check wheter this move is valid
valid_move(R1,C1,R2,C2):-R2 is R1+1, C2 is C1+1,R2<9,C2<9,R2>0,C2>0,!.
valid_move(R1,C1,R2,C2):-R2 is R1+1, C2 is C1-1,R2<9,C2<9,R2>0,C2>0,!.
valid_move(R1,C1,R2,C2):-R2 is R1-1, C2 is C1+1,R2<9,C2<9,R2>0,C2>0,!.
valid_move(R1,C1,R2,C2):-R2 is R1-1, C2 is C1-1,R2<9,C2<9,R2>0,C2>0,!.
% Check wheter this bit is valid
valid_bit(R1,C1,R2,C2,R3,C3):-R2 is R1+2, C2 is C1+2,R3 is R1+1, C3 is C1+1,R2<9,C2<9,R2>0,C2>0,!.
valid_bit(R1,C1,R2,C2,R3,C3):-R2 is R1+2, C2 is C1-2,R3 is R1+1, C3 is C1-1,R2<9,C2<9,R2>0,C2>0,!.
valid_bit(R1,C1,R2,C2,R3,C3):-R2 is R1-2, C2 is C1+2,R3 is R1-1, C3 is C1+1,R2<9,C2<9,R2>0,C2>0,!.
valid_bit(R1,C1,R2,C2,R3,C3):-R2 is R1-2, C2 is C1-2,R3 is R1-1, C3 is C1-1,R2<9,C2<9,R2>0,C2>0,!.
not(X):-X,!,fail.
not(X).
check_move(([R1,C1] --> [R2,C2]),B,PL1,PL2):-empty_cell(R2,C2,B),not(empty_cell(R1,C1,PL1)),
valid_move(R1,C1,R2,C2).
check_bit(([R1,C1] --> [R2,C2]),B,PL1,PL2,R3,C3):-empty_cell(R2,C2,B),not(empty_cell(R1,C1,PL1)),
valid_bit(R1,C1,R2,C2,R3,C3),not(empty_cell(R3,C3,PL2)).
%Move check
make_move(([0,0] --> [0,0]),_,_,_).
make_move(([R1,C1] --> [R2,C2]),B,PL1,PL2):-check_move(([R1,C1] --> [R2,C2]),B,PL1,PL2),
delete(PL1,[p,R1,C1],PPL1),
append(PPL1,[[p,R2,C2]],PNL1),
retract(brd(B,PL1,PL2)),
NB = brd(B,PNL1,PL2),
assertz(NB).
%Bit a check
make_move(([R1,C1] --> [R2,C2]),B,PL1,PL2):-check_bit(([R1,C1] --> [R2,C2]),B,PL1,PL2,R3,C3),
delete(PL1,[p,R1,C1],PPL1),
delete(PL2,[p,R3,C3],PPL2),
append(PPL1,[[p,R2,C2]],PNL1),
retract(brd(B,PL1,PL2)),
NB = brd(B,PNL1,PPL2),
assertz(NB).
chck_fin.
plr_move(PL1,PL2):- make_input(X),
parse_input(X),
make_move(X,b,PL1,PL2),
chck_fin,!.
comp_move(PL1,PL2):- assertz(move_cost([0,0,0,0,0])),
generate_move(PL1,PL2,b),
retract(move_cost([X,R1,C1,R2,C2])),
nl,display('---------------'),nl,
display('Computer moves:'),
write(([R1,C1]-->[R2,C2])),nl,nl,
make_move(([R1,C1]-->[R2,C2]),b,PL1,PL2),
can_bit(R2,C2),!.
can_bit(0,0).
can_bit(R1,C1):-
brd(b,PL1,PL2),
findall((R1,C1,R2,C2,R3,C3),v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2),VB),
assertz(move_cost([0,0,0,0,0])),
analyze_move([],VB),
retract(move_cost([X,RR1,CC1,RR2,CC2])),
make_move(([RR1,CC1]-->[RR2,CC2]),b,PL1,PL2),
can_bit(RR2,CC2),!.
%All valid moves
%v_m(B,R1,C1,R2,C2,PL1,PL2):-R2 is R1+1, C2 is C1+1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)).
%v_m(B,R1,C1,R2,C2,PL1,PL2):-R2 is R1+1, C2 is C1-1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)).
v_m(B,R1,C1,R2,C2,PL1,PL2):-R2 is R1-1, C2 is C1+1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)).
v_m(B,R1,C1,R2,C2,PL1,PL2):-R2 is R1-1, C2 is C1-1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)).
%All valid bits
v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2):-R2 is R1+2, C2 is C1+2,R3 is R1+1, C3 is C1+1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)),not(empty_cell(R3,C3,B,PL2)).
v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2):-R2 is R1+2, C2 is C1-2,R3 is R1+1, C3 is C1-1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)),not(empty_cell(R3,C3,B,PL2)).
v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2):-R2 is R1-2, C2 is C1+2,R3 is R1-1, C3 is C1+1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)),not(empty_cell(R3,C3,B,PL2)).
v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2):-R2 is R1-2, C2 is C1-2,R3 is R1-1, C3 is C1-1,R2<9,C2<9,R2>0,C2>0,empty_cell(R2,C2,B),not(empty_cell(R1,C1,B,PL1)),not(empty_cell(R3,C3,B,PL2)).
%Generates all possible moves
generate_move([[p,R1,C1]|Y],PL2,B):-brd(B,PL1,PL2),
findall((R1,C1,R2,C2),v_m(B,R1,C1,R2,C2,PL1,PL2),VM),
findall((R1,C1,R2,C2,R3,C3),v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2),VB),
% write(VM),
% write(VB),
% nl,
analyze_move(VM,VB),
generate_move(Y,PL2,B),!.
generate_move(_,_,_).
%Calculate cost function
gen_move_lst([[p,R1,C1]|Y],PL1,PL2,B,[(VM,VB,[p,R1,C1])|L]):-
findall((R1,C1,R2,C2),v_m(B,R1,C1,R2,C2,PL1,PL2),VM),
findall((R1,C1,R2,C2,R3,C3),v_b(B,R1,C1,R2,C2,R3,C3,PL1,PL2),VB),
gen_move_lst(Y,PL1,PL2,B,L),!.
gen_move_lst(_,_,_,_,[]).
max([X|X1],[Y|Y1],Z):- X>Y,Z=[X|X1],!.
max(X,Y,Z):- Z = Y,!.
calc_cost(B,R):-brd(B,PL1,PL2),
gen_move_lst(PL1,PL1,PL2,B,L),
gen_move_lst(PL2,PL2,PL1,B,L1),
weight(L,Rc1),
weight(L1,Rc2),
R is Rc1 / Rc2.
weight([(VM,VB,_)|Y],R):-length(VM,Rc1),
length(VB,Rc2),
weight(Y,R1),
R is R1 + Rc1 + 2*Rc2.
weight([],0).
%length(L,R).
%Analyze all moves and select best.
analyze_move(A,[(R1,C1,R2,C2,_,_)|Y]):- brd(b,PL1,PL2),
NB =brd(cmp,PL1,PL2),
assertz(NB),
make_move(([R1,C1] --> [R2,C2]),cmp,PL1,PL2),
calc_cost(cmp,REZ),
retract(brd(cmp,_,_)),
retract(move_cost(Old_cost)),
max([REZ,R1,C1,R2,C2],Old_cost,New_cost),
NMV = move_cost(New_cost),
assertz(NMV),
analyze_move([],Y),!.
analyze_move([(R1,C1,R2,C2)|Y],[]):- brd(b,PL1,PL2),
NB = brd(cmp,PL1,PL2),
assertz(NB),
make_move(([R1,C1] --> [R2,C2]),cmp,PL1,PL2),
calc_cost(cmp,REZ),
retract(brd(cmp,_,_)),
retract(move_cost(Old_cost)),
max([REZ,R1,C1,R2,C2],Old_cost,New_cost),
NMV = move_cost(New_cost),
assertz(NMV),
analyze_move(Y,[]),!.
analyze_move([],[]).
Задача Энштейна
houses([
house(first, _, _, _, _, _),
house(second, _, _, _, _, _),
house(third, _, _, _, _, _),
house(forth, _, _, _, _, _),
house(fifth, _, _, _, _, _)
]).
right_of(A, B, [B, A | _]).
right_of(A, B, [_ | Y]) :- right_of(A, B, Y).
next_to(A, B, [A, B | _]).
next_to(A, B, [B, A | _]).
next_to(A, B, [_ | Y]) :- next_to(A, B, Y).
mymember(X, [X|_]).
mymember(X, [_|Y]) :- mymember(X, Y).
print_houses([]).
print_houses([A|B]) :-
write(A), nl,
print_houses(B).
where_fish(H):-houses(H),
mymember(house(_,red,english,_,_,_),H),
mymember(house(_,_,swedish,dog,_,_),H),
mymember(house(_,_,datman,_,tea,_),H),
right_of(house(_,green,_,_,_,_),
house(_,white,_,_,_,_),H),
mymember(house(_,green,_,_,coffe,_),H),
mymember(house(_,_,_,bird,_,pallmall),H),
H=[_,_,house(_,_,_,_,milk,_),_,_],
mymember(house(_,yellow,_,_,_,dunhill),H),
mymember(house(first,_,norway,_,_,_),H),
next_to(house(_,_,_,_,_,marlboro),
house(_,_,_,cat,_,_),H),
next_to(house(_,_,_,horse,_,_),
house(_,_,_,_,_,dunhill),H),
mymember(house(_,_,_,_,bear,winfield),H),
next_to(house(_,_,norway,_,_,_),
house(_,blue,_,_,_,_),H),
mymember(house(_,_,denmark,_,_,rothmans),H),
next_to(house(_,_,_,_,_,marlboro),
house(_,_,_,_,water,_),H),
print_houses(H).
Найти множество First K . version 1
(defun non_terminals (rule)
(cond ( (eql rule nil) nil)
( (> (car rule) 0) (non_terminals (cdr rule)))
( (< (car rule) 0) (union (list (car rule)) (non_terminals (cdr rule))))
)
)
(defun terminals (rule)
(cond ( (eql rule nil) nil)
( (< (car rule) 0) (terminals (cdr rule)))
( (> (car rule) 0) (union (list (car rule)) (terminals (cdr rule))))
)
)
;build terminals set
(defun bts (gram)
(cond ( (eql gram nil) nil)
( (union (terminals (car gram)) (bts (cdr gram))))
)
)
;build neterminal set
(defun bns (gram)
(cond ( (eql gram nil) nil)
( (union (non_terminals (car gram)) (bns (cdr gram))))
)
)
;equals two lists
(defun eql_l (lst1 lst2)
(cond ( (eql lst1 nil) (eql lst2 nil) )
( (eql (car lst1) (car lst2)) (eql_l (cdr lst1) (cdr lst2)) )
( 1 nil )
)
)
;check if lst1 is an element of lst
(defun is_in (lst1 lst)
(cond ( (eql lst nil) nil)
( (eql_l (car lst) lst1) T)
( 1 (is_in lst1 (cdr lst)) )
)
)
;union of two lists with sub lists
(defun union_lst (lst1 lst2)
(cond ( (eql lst2 nil) lst1 )
( (eql lst1 nil) lst2 )
( (is_in (car lst2) lst1) (union_lst lst1 (cdr lst2)) )
( 1 (union (list(car lst2)) (union_lst lst1 (cdr lst2))) )
)
)
;first step
(defun first0 (A GRAM)
(cond ( (eql GRAM nil) nil)
( (eql A (caar GRAM)) (union_lst (list (cdar GRAM)) (first0 A (cdr GRAM))))
( (first0 A (cdr GRAM)))
)
)
;list before item a
(defun before (a lst)
(cond ( (eql lst nil) nil )
( (eql a (car lst)) nil )
( (append (list (car lst)) (before a (cdr lst))) )
)
)
;list afer item a
(defun after (a lst)
(cdr (member a lst))
)
;find first non terminal
(defun fnt (rule)
(cond ( (eql rule nil) nil)
( (> (car rule) 0) (fnt (cdr rule)) )
( (eql (car rule) 0) (fnt (cdr rule)) )
( (< (car rule) 0) (car rule) )
)
)
;build a set of all rules that produces by changing neterminal N with all posible inference rules
(defun change (rule N GRAM)
(cond ( (eql GRAM nil) nil)
( (eql N (caar GRAM)) (union_lst (list(append (before N rule) (append (cdar GRAM) (after N rule)))) (change rule N (cdr GRAM))) )
( 1 (change rule N (cdr GRAM)))
)
)
;Next iteration step for building firstk
(defun first1 (rules GRAM)
(cond ( (eql rules nil) nil)
( (fnt (car rules)) (union_lst (change (car rules) (fnt (car rules)) GRAM) (first1 (cdr rules) GRAM) ))
( 1 ( union_lst (list(car rules)) (first1 (cdr rules) GRAM) ) )
)
)
;truncate list to k symbols
(defun trunc (K lst)
(cond ( (> K (length lst)) lst )
( (= K (length lst)) lst )
( (> K 0) (append (list(car lst)) (trunc (- k 1) (cdr lst))) )
)
)
;truncate all rule in list rules to K symbols
(defun trunc_rules(K rules)
(cond ( (eql rules nil) nil)
( 1 (union_lst (list(trunc K (car rules))) (trunc_rules K (cdr rules))))
)
)
; rule1 << rule2
(defun vkluch(rules1 rules2)
(cond ((eql rules1 nil) 1)
((is_in (car rules1) rules2) (vkluch (cdr rules1) rules2))
(1 nil)
)
)
; rules1 == rules2
(defun check_rules(rules1 rules2)
(cond ( (vkluch rules1 rules2) (vkluch rules2 rules1) )
( 1 nil)
)
)
;first K net
(defun firstk(A K GRAM)
(set 'rules (first0 A GRAM))
; (print "Calculating FIRSTk for Neterminal")
; (print A)
; (print "--------------------------------")
(LOOP
(set 'rules1 (first1 rules GRAM))
(if (check_rules(trunc_rules K rules)(trunc_rules K rules1)) (return (trunc_rules K rules))
(set 'rules rules1)
)
)
)
;first K for each neterminal in NET
(defun firstk_s (K GRAM NET)
(cond ( (eql NET nil) )
( (print (firstk (car NET) K GRAM)) (firstk_s K GRAM (cdr NET)))
)
)
;follow S - starting non terminal from GRAMMAR
(defun follow0(A GRAM)
(cond
((eql GRAM nil) nil)
((member A (cdar GRAM)) (union_lst (list(after A (cdar GRAM))) (follow0 A (cdr GRAM))) )
(1 (follow0 A (cdr GRAM)))
)
)
;append_n
(defun append_n (rules tail)
(cond ( (eql rules nil) nil)
( 1 (union_lst(list(append (car rules) tail)) (append_n (cdr rules) tail)) )
)
)
;cons_n
(defun cons_n (head rules)
(cond ( (eql rules nil) (list(list head)))
( 1 (union_lst (list(cons head (car rules))) (cons_n head (cdr rules)) ))
)
)
;build followk
(defun follow1(rule K GRAM)
(cond ( (eql rule nil) nil)
( (MINUSP (car rule)) (append_n (firstk (car rule) K GRAM) (cdr rule)) )
( 1 (cons_n (car rule) (follow1(cdr rule) K GRAM) ) )
)
)
;build followk
(defun follow1(rule K GRAM)
(cond ( (eql rule nil) nil)
( (MINUSP (car rule)) (append_n (firstk (car rule) K GRAM) (cdr rule)) )
( 1 (cons_n (car rule) (follow1(cdr rule) K GRAM) ) )
)
)
;follow for each rule
(defun follow1_s (rules K GRAM)
(cond ( (eql rules nil) nil )
( 1 (union_lst (follow1 (car rules) K GRAM) (follow1_s (cdr rules) k GRAM)) )
)
)
;follow K net
(defun follow(A S K GRAM)
(set 'rules (follow0 A GRAM))
(LOOP
(set 'rules1 (follow1_s rules K GRAM))
(if (check_rules(trunc_rules K rules)(trunc_rules K rules1)) (return (trunc_rules K rules))
(set 'rules (union_lst rules rules1))
)
)
)
;follow K for each neterminal in NET
(defun followk_s (K S GRAM NET)
(cond ( (eql NET nil) )
( 1 (print (follow (car NET) S K GRAM)) (followk_s K S GRAM (cdr NET)))
)
)
;first K solution
;exmple: (solve 3 '( (-3 1 -2 -3) (-2 22) (-2) (-2 -1 3 4) (-1 0) ))
; (solve 1 '( (-1 -3 -2) (-2) (-2 20 -3 -2) (-3 -5 -4) (-4) (-4 30 -5 -4) (-5 1 -1 2) (-5 101)))
;
(defun solve (K GRAM)
(set 'Net (bns GRAM))
(set 'Ter (bts GRAM))
(print "Terminals:")
(print Ter)
(print "Non Terminals:")
(print Net)
(print "FirstK::")
(firstk_s K GRAM Net)
)
Найти множество First K . version 2
; February 2005 Процик П П
; First K
;
(defun non_terminals (rule)
(cond ( (eql rule nil) nil)
( (eql (car rule) nil) (non_terminals(cdr rule)))
( (> (car rule) 0) (non_terminals (cdr rule)))
( (< (car rule) 0) (union (list (car rule)) (non_terminals (cdr rule))))
)
)
(defun terminals (rule)
(cond ( (eql rule nil) nil)
( (< (car rule) 0) (terminals (cdr rule)))
( (> (car rule) 0) (union (list (car rule)) (terminals (cdr rule))))
)
)
;build terminals set
(defun bts (gram)
(cond ( (eql gram nil) nil)
( (union (terminals (car gram)) (bts (cdr gram))))
)
)
;build neterminal set
(defun bns (gram)
(cond ( (eql gram nil) nil)
( (union (non_terminals (car gram)) (bns (cdr gram))))
)
)
;equals two lists
(defun eql_l (lst1 lst2)
(cond ( (eql lst1 nil) (eql lst2 nil) )
( (eql (car lst1) (car lst2)) (eql_l (cdr lst1) (cdr lst2)) )
( 1 nil )
)
)
;check if lst1 is an element of lst
(defun is_in (lst1 lst)
(cond ( (eql lst nil) nil)
( (eql_l (car lst) lst1) T)
( 1 (is_in lst1 (cdr lst)) )
)
)
;union of two lists with sub lists
(defun union_lst (lst1 lst2)
(cond ( (eql lst2 nil) lst1 )
( (eql lst1 nil) lst2 )
( (is_in (car lst2) lst1) (union_lst lst1 (cdr lst2)) )
( 1 (union (list(car lst2)) (union_lst lst1 (cdr lst2))) )
)
)
;first step
(defun first0 (A GRAM)
(cond ( (eql GRAM nil) nil)
( (eql A (caar GRAM)) (union_lst (list (cdar GRAM)) (first0 A (cdr GRAM))))
( (first0 A (cdr GRAM)))
)
)
;list before item a
(defun before (a lst)
(cond ( (eql lst nil) nil )
( (eql a (car lst)) nil )
( (append (list (car lst)) (before a (cdr lst))) )
)
)
;list afer item a
(defun after (a lst)
(cdr (member a lst))
)
;find first non terminal
(defun fnt (rule)
(cond ( (eql rule nil) nil)
( (> (car rule) 0) (fnt (cdr rule)) )
( (eql (car rule) 0) (fnt (cdr rule)) )
( (< (car rule) 0) (car rule) )
)
)
;build a set of all rules that produces by changing neterminal N with all posible inference rules
(defun change (rule N GRAM)
(cond ( (eql GRAM nil) nil)
( (eql N (caar GRAM)) (union_lst (list(append (before N rule) (append (cdar GRAM) (after N rule)))) (change rule N (cdr GRAM))) )
( 1 (change rule N (cdr GRAM)))
)
)
;Next iteration step for building firstk
(defun first1 (rules GRAM)
(cond ( (eql rules nil) nil)
( (fnt (car rules)) (union_lst (change (car rules) (fnt (car rules)) GRAM) (first1 (cdr rules) GRAM) ))
( 1 ( union_lst (list(car rules)) (first1 (cdr rules) GRAM) ) )
)
)
;truncate list to k symbols
(defun trunc (K lst)
(cond ( (> K (length lst)) lst )
( (= K (length lst)) lst )
( (> K 0) (append (list(car lst)) (trunc (- k 1) (cdr lst))) )
)
)
;truncate all rule in list rules to K symbols
(defun trunc_rules(K rules)
(cond ( (eql rules nil) nil)
( 1 (union_lst (list(trunc K (car rules))) (trunc_rules K (cdr rules))))
)
)
(defun remove_net_from_rule (rule)
(cond ( (eql rule nil) nil)
( (fnt rule) nil )
( 1 rule)
)
)
(defun remove_net_from_rules(rules)
(cond ( (eql rules nil) nil)
( 1 (union_lst (list (remove_net_from_rule (car rules))) (remove_net_from_rules(cdr rules))))
)
)
; rule1 << rule2
(defun vkluch(rules1 rules2)
(cond ((eql rules1 nil) 1)
((is_in (car rules1) rules2) (vkluch (cdr rules1) rules2))
(1 nil)
)
)
; rules1 == rules2
(defun check_rules(rules1 rules2)
(cond ( (vkluch rules1 rules2) (vkluch rules2 rules1) )
( 1 nil)
)
)
;first K net
(defun firstk(A K GRAM)
(set 'rules (first0 A GRAM))
; (print "Calculating FIRSTk for Neterminal")
; (print A)
; (print "--------------------------------")
(LOOP
(set 'rules1 (first1 rules GRAM))
(if (check_rules(trunc_rules K rules)(trunc_rules K rules1))
(return (remove_net_from_rules (trunc_rules K rules)))
(set 'rules rules1)
)
)
)
;first K for each neterminal in NET
(defun firstk_s (K GRAM NET)
(cond ( (eql NET nil) nil)
( 1 (cons (list (car NET) (firstk (car NET) K GRAM)) (firstk_s K GRAM (cdr NET))))
)
)
;first K solution
;exmple:
; (solve 3 '( (-3 1 -2 -3) (-2 22) (-2) (-2 -1 3 4) (-1 0) ))
; (solve 1 '( (-1 -3 -2) (-2) (-2 20 -3 -2) (-3 -5 -4) (-4) (-4 30 -5 -4) (-5 1 -1 2) (-5 101)))
;
(defun solve (K GRAM)
(set 'Net (bns GRAM))
(set 'Ter (bts GRAM))
(print "Terminals:")
(print Ter)
(print "Non Terminals:")
(print Net)
(print "FirstK::")
(firstk_s K GRAM Net)
)
FOLLOW K , возможно не доделанная версия
; Ne dodelana
(defun non_terminals (rule)
(cond ( (eql rule nil) nil)
( (eql (car rule) nil) (non_terminals(cdr rule)))
( (> (car rule) 0) (non_terminals (cdr rule)))
( (< (car rule) 0) (union (list (car rule)) (non_terminals (cdr rule))))
)
)
(defun terminals (rule)
(cond ( (eql rule nil) nil)
( (< (car rule) 0) (terminals (cdr rule)))
( (> (car rule) 0) (union (list (car rule)) (terminals (cdr rule))))
)
)
;build terminals set
(defun bts (gram)
(cond ( (eql gram nil) nil)
( (union (terminals (car gram)) (bts (cdr gram))))
)
)
;build neterminal set
(defun bns (gram)
(cond ( (eql gram nil) nil)
( (union (non_terminals (car gram)) (bns (cdr gram))))
)
)
;equals two lists
(defun eql_l (lst1 lst2)
(cond ( (eql lst1 nil) (eql lst2 nil) )
( (eql (car lst1) (car lst2)) (eql_l (cdr lst1) (cdr lst2)) )
( 1 nil )
)
)
;check if lst1 is an element of lst
(defun is_in (lst1 lst)
(cond ( (eql lst nil) nil)
( (eql_l (car lst) lst1) T)
( 1 (is_in lst1 (cdr lst)) )
)
)
;union of two lists with sub lists
(defun union_lst (lst1 lst2)
(cond ( (eql lst2 nil) lst1 )
( (eql lst1 nil) lst2 )
( (is_in (car lst2) lst1) (union_lst lst1 (cdr lst2)) )
( 1 (union (list(car lst2)) (union_lst lst1 (cdr lst2))) )
)
)
;first step
(defun first0 (A GRAM)
(cond ( (eql GRAM nil) nil)
( (eql A (caar GRAM)) (union_lst (list (cdar GRAM)) (first0 A (cdr GRAM))))
( (first0 A (cdr GRAM)))
)
)
;list before item a
(defun before (a lst)
(cond ( (eql lst nil) nil )
( (eql a (car lst)) nil )
( (append (list (car lst)) (before a (cdr lst))) )
)
)
;list afer item a
(defun after (a lst)
(cdr (member a lst))
)
;find first non terminal
(defun fnt (rule)
(cond ( (eql rule nil) nil)
( (> (car rule) 0) (fnt (cdr rule)) )
( (eql (car rule) 0) (fnt (cdr rule)) )
( (< (car rule) 0) (car rule) )
)
)
;build a set of all rules that produces by changing neterminal N with all posible inference rules
(defun change (rule N GRAM)
(cond ( (eql GRAM nil) nil)
( (eql N (caar GRAM)) (union_lst (list(append (before N rule) (append (cdar GRAM) (after N rule)))) (change rule N (cdr GRAM))) )
( 1 (change rule N (cdr GRAM)))
)
)
;Next iteration step for building firstk
(defun first1 (rules GRAM)
(cond ( (eql rules nil) nil)
( (fnt (car rules)) (union_lst (change (car rules) (fnt (car rules)) GRAM) (first1 (cdr rules) GRAM) ))
( 1 ( union_lst (list(car rules)) (first1 (cdr rules) GRAM) ) )
)
)
;truncate list to k symbols
(defun trunc (K lst)
(cond ( (> K (length lst)) lst )
( (= K (length lst)) lst )
( (> K 0) (append (list(car lst)) (trunc (- k 1) (cdr lst))) )
)
)
;truncate all rule in list rules to K symbols
(defun trunc_rules(K rules)
(cond ( (eql rules nil) nil)
( 1 (union_lst (list(trunc K (car rules))) (trunc_rules K (cdr rules))))
)
)
; rule1 << rule2
(defun vkluch(rules1 rules2)
(cond ((eql rules1 nil) 1)
((is_in (car rules1) rules2) (vkluch (cdr rules1) rules2))
(1 nil)
)
)
; rules1 == rules2
(defun check_rules(rules1 rules2)
(cond ( (vkluch rules1 rules2) (vkluch rules2 rules1) )
( 1 nil)
)
)
;first K net
(defun firstk(A K GRAM)
(set 'rules (first0 A GRAM))
; (print "Calculating FIRSTk for Neterminal")
; (print A)
; (print "--------------------------------")
(LOOP
(set 'rules1 (first1 rules GRAM))
(if (check_rules(trunc_rules K rules)(trunc_rules K rules1)) (return (trunc_rules K rules))
(set 'rules rules1)
)
)
)
;first K for each neterminal in NET
(defun firstk_s (K GRAM NET)
(cond ( (eql NET nil) )
( 1 (cons (list (car NET) (firstk (car NET) K GRAM)) (firstk_s K GRAM (cdr NET))))
)
)
;follow S - starting non terminal from GRAMMAR
(defun follow0_calc(A GRAM)
(cond
((eql GRAM nil) nil)
((member A (cdar GRAM)) (union_lst (list(after A (cdar GRAM))) (follow0_calc A (cdr GRAM))) )
(1 (follow0_calc A (cdr GRAM)))
)
)
(defun follow0(GRAM NET)
(cond
((eql NET nil) nil)
(1 (cons (list (car NET) (follow0_calc (car NET) GRAM)) (follow0 GRAM (cdr NET))) )
)
)
(defun frst_lst (N FK)
(cond ( (eql FK nil) nil )
( (eql N (caar FK)) (cadar FK) )
( 1 (frst_lst N (cdr FK)) )
)
)
(defun frst_union (FN FK)
(cond ( (eql FN nil) nil)
( 1 (union_lst (frst_lst (car FN) FK) (frst_union (cdr FN) FK)) )
)
)
;FK - first K F0 = (follow0 GRAM (bns GRAM))
(defun follow_1 (GRAM F0 FK)
(cond ( (eql F0 nil) nil))
(set 'FF (cadar F0))
(set 'FN (bns FF))
(cond ( (eql FN nil) (cons (car F0) (follow_1 GRAM (cdr F0) FK)) )
( 1 (cons (list (caar F0) (union (frst_union FN FK) (cadar F0))) (follow_1 GRAM (cdr F0) FK)) )
)
)
;append_n
(defun append_n (rules tail)
(cond ( (eql rules nil) nil)
( 1 (union_lst(list(append (car rules) tail)) (append_n (cdr rules) tail)) )
)
)
;cons_n
(defun cons_n (head rules)
(cond ( (eql rules nil) (list(list head)))
( 1 (union_lst (list(cons head (car rules))) (cons_n head (cdr rules)) ))
)
)
;build followk
(defun follow1(rule K GRAM)
(cond ( (eql rule nil) nil)
( (MINUSP (car rule)) (append_n (firstk (car rule) K GRAM) (cdr rule)) )
( 1 (cons_n (car rule) (follow1(cdr rule) K GRAM) ) )
)
)
;build followk
(defun follow1(rule K GRAM)
(cond ( (eql rule nil) nil)
( (MINUSP (car rule)) (append_n (firstk (car rule) K GRAM) (cdr rule)) )
( 1 (cons_n (car rule) (follow1(cdr rule) K GRAM) ) )
)
)
;follow for each rule
(defun follow1_s (rules K GRAM)
(cond ( (eql rules nil) nil )
( 1 (union_lst (follow1 (car rules) K GRAM) (follow1_s (cdr rules) k GRAM)) )
)
)
;follow K net
(defun follow(A S K GRAM)
(set 'rules (follow0 A GRAM))
(LOOP
(set 'rules1 (follow1_s rules K GRAM))
(if (check_rules(trunc_rules K rules)(trunc_rules K rules1)) (return (trunc_rules K rules))
(set 'rules (union_lst rules rules1))
)
)
)
;follow K for each neterminal in NET
(defun followk_s (K S GRAM NET)
(cond ( (eql NET nil) )
( 1 (print (follow (car NET) S K GRAM)) (followk_s K S GRAM (cdr NET)))
)
)
;first K solution
;exmple: (solve 3 '( (-3 1 -2 -3) (-2 22) (-2) (-2 -1 3 4) (-1 0) ))
; (solve 1 '( (-1 -3 -2) (-2) (-2 20 -3 -2) (-3 -5 -4) (-4) (-4 30 -5 -4) (-5 1 -1 2) (-5 101)))
;
(defun solve (K GRAM)
(set 'Net (bns GRAM))
(set 'Ter (bts GRAM))
(print "Terminals:")
(print Ter)
(print "Non Terminals:")
(print Net)
(print "FirstK::")
(firstk_s K GRAM Net)
(print "FollowK::")
(followk_s K (caar GRAM) GRAM (bns GRAM))
)
Операции над списками
(defun is_in (el lst)
( (eql lst nil) nil )
( (not (eql el (car lst))) (is_in el (cdr lst)) )
( (eql el (car lst)))
)
(defun minus (lst1 lst2)
( (eql lst1 nil) nil )
( (eql lst2 nil) nil )
( (is_in (car lst1) lst2) (minus (cdr lst1) lst2) )
( (cons (car lst1) (minus (cdr lst1) lst2)) )
)
(defun union (lst1 lst2)
( (eql lst1 nil) lst2 )
( (cons (car lst1) (union (cdr lst1) lst2)) )
)
(defun xor (lst1 lst2)
( (union (minus lst1 lst2) (minus lst2 lst1) ) )
)
; ПРОГРАММА ДЛЯ ПОСТРОЕНИЯ МАГИЧЕСКИХ КВАДРАТОВ (Решение не моё)
; Доступ к (i,j) элементу
; а - массив (список)
; n - размерность массива
; i,j - элемент
(defun @ (a n i j)
(eval (nth (+ (* i n) j) a))
)
; Запись в (i,j) элемент
; а - массив (список)
; n - размерность массива
; i,j - элемент
; elem - новое значение
; Возвращает новый массив
(defun @w (a n i j elem)
(setf (nth (+ (* i n) j) a) elem)
(setq a a)
)
; Распечатка содержимого массивов
; a - массив
; n - размерность
(defun prn (a n)
(format T "~%")
(do ((i 0 (+ i 1))) ((= i n))
(do ((j 0 (+ j 1))) ((= j n))
(if (> (@ a n i j) 9)
(format T " ~A" (@ a n i j))
(format T " ~A" (@ a n i j))
)
)
(format T "~%")
)
)
; Создание пустого массива размерностью n*n
(defun clear (n)
(setq a '())
(do ((i 0 (+ i 1))) ((= i (* n n))) (setq a (cons '0 a)))
(setq a a)
)
(defun make (flag)
(setq k 0)
(do () ( (AND (> k 2) (= (rem k 2) 1)) )
(format T "~%Введите размерность магического квадрата.")
(format T "~%Число должно быть НЕЧЕТНЫМ и больше 2 :")
(setq k (read))
)
(setq n (- (* k 2) 1))
(setq delta (/ (- n k) 2))
(setq a (clear n))
(if flag (prn a n))
(setq pointer (setq start (- k 1) ))
(do ((i 1 (+ i 1))) ((> i (* k k)))
(setf (nth pointer a) i)
(if (= (rem i k) 0)
(setq pointer (setq start (- (+ start n) 1) ))
(setq pointer (+ pointer n 1))
)
)
(if flag (progn
(format T "~%Введите любой символ для продолжения:")
(read)
(prn a n)
))
(do ((i 0 (+ i 1))) ((= i n))
(do ((j 0 (+ j 1))) ((= j n))
(if (> (@ a n i j) 0)
(cond
((< i delta) ; Верхняя часть
(setq a (@w a n (+ i k) j (@ a n i j)))
)
((< j delta) ; Левая часть
(setq a (@w a n i (+ j k) (@ a n i j)))
)
((>= j (- n delta)) ; Правая часть
(setq a (@w a n i (- j k) (@ a n i j)))
)
((>= i (- n delta)) ; Нижняя часть
(setq a (@w a n (- i k) j (@ a n i j)))
)
)
)
)
)
(if flag (progn
(format T "~%Введите любой символ для продолжения:")
(read)
(prn a n)
))
(setq b '())
(do ((i 0 (+ i 1))) ((= i n))
(do ((j 0 (+ j 1))) ((= j n))
(if (AND (>= i delta) (>= j delta) (> (- n delta) j) (> (- n delta) i) )
(setq b (cons (@ a n i j) b))
)
)
)
(if flag (progn
(format T "~%Введите любой символ для продолжения:")
(read)
))
(setq b (reverse b))
(prn b k)
)
; Основной модуль
(do ((c 0)) ((= c 1))
(format T "~%~%МАГИЧЕСКИЙ КВАДРАТ.")
(format T "~%Меню:")
(format T "~% 1. Построение магического квадрата.")
(format T "~% 2. Подробное построение магического квадрата.")
(format T "~% 0. Выход")
(format T "~%Ваш выбор:")
(setq temp (read))
(cond
((= temp 1) (make nil))
((= temp 2) (make T))
((= temp 0)
(setq c 1) ; Укажем, что необходимо выйти из программы
)
)
)
; 29.03.2005 Процик П П
; На вход подается матрица и два списка:
; a11 a12 | rgh1
; a21 a22 | rgh2
; ---- ----
; btn1 bnt2
; матрица состоит из символов а списки из чисел
; программа находит такие подстановки чисел вместо
; символов матрицы чтобы сумы по вертикали и горизонтали
; равнялись соответсвующим елементам списков
; использование (solve '((a b) (b a)) '(3 3) '(3 3))
; (solve '((a a b) (b a c) (c b a)) '(4 6 6) '(6 4 6))
(defun rec(n_ func)
(setq lst nil)
(setq stk nil)
(recurse lst stk 1 n_ func)
)
(defun recurse(lst stk k_ n_ func)
(cond ( (> k_ n_) (funcall func lst) )
( 1 (setq c_ 0)
(loop
(cond ((eql c_ 10) (return T)))
(push c_ stk)
(recurse (append lst (list c_)) stk (+ k_ 1) n_ func)
(setq c_ (pop stk))
(setq c_ (+ c_ 1))
)
)
)
)
(defun trans(matr)
(cond
((every 'NULL matr) nil )
(1 (cons (mapcar 'car matr) (trans (mapcar 'cdr matr))))
)
)
(defun sum (lst)
(cond ( (eql lst nil) 0)
( (atom lst) lst )
( 1 (+ (car lst) (sum (cdr lst))))
)
)
(defun chk (lst1 lst2)
(cond ( (eql lst1 nil) (eql lst2 nil) )
( (eql (car lst1) (car lst2)) (chk (cdr lst1) (cdr lst2)) )
( 1 nil)
)
)
(defun check (matr rgh btn)
(cond
( (chk rgh (mapcar 'sum matr)) (chk btn (mapcar 'sum (trans matr))) )
( 1 nil)
)
)
;------------------------- Problem solution -------------------------------
(defun is_in (el lst)
(cond ( (eql lst nil) nil)
( (eql el (car lst)) T)
( 1 (is_in el (cdr lst)) )
)
)
(defun union_lst (lst1 lst2)
(cond ( (eql lst2 nil) lst1 )
( (eql lst1 nil) lst2 )
( (is_in (car lst1) lst1) (union_lst (cdr lst1) lst2) )
( (is_in (car lst2) lst1) (union_lst lst1 (cdr lst2)) )
( 1 (cons (car lst2) (union_lst lst1 (cdr lst2))) )
)
)
(defun uni_union (lst)
(cond ((eql lst nil) nil)
(1 (union_lst (car lst) (uni_union (cdr lst))))
)
)
(defun val_of (var vals alp)
(cond ( (eql vals nil) nil )
( (eql alp nil) nil )
( (eql var (car alp)) (car vals) )
( 1 (val_of var (cdr vals) (cdr alp)) )
)
)
(defun podstav (vars vals alp)
(cond ( (eql vars nil) nil)
( 1 (cons (val_of (car vars) vals alp) (podstav (cdr vars) vals alp)) )
)
)
(defun podstav_matr (matr vals alp)
(cond ( (eql matr nil) nil)
( 1 (cons (podstav (car matr) vals alp) (podstav_matr (cdr matr) vals alp)) )
)
)
(defun rec_func(matr rgh btn vals alp)
(cond ( (check (podstav_matr matr vals alp) rgh btn) (print vals) ))
)
(defun solve (matr rgh btn)
(setq alp (uni_union matr))
(print alp)
(rec (length alp) (LAMBDA (lst) (rec_func matr rgh btn lst alp)))
)
% 28.03.2005 Процик П П
% Раскладывает число на слагаемые
% использование (next '(num))
(defun get_s(lst)
(cond ( (eql lst nil) 0 )
( (eql (car lst) 1) (+ 1 (get_s (cdr lst))) )
( 1 1)
)
)
(defun dec_trunc(lst s c)
(cond ((eql lst nil) nil)
((eql s c) (list (- (car lst) 1)) )
( 1 (cons (car lst) (dec_trunc (cdr lst) s (+ c 1))) )
)
)
(defun sum(lst s c)
(cond ((eql lst nil) 0)
((< c s) (+ (car lst) (sum (cdr lst) s (+ c 1)) ))
( 1 (sum (cdr lst) s (+ c 1)) )
)
)
(defun next(lst)
(setq k (length lst))
(setq sum_all (sum lst (+ k 1) 1))
(setq s (- (+ k 1) (get_s (reverse lst))))
(setq lst (dec_trunc lst s 1))
(setq sum_now (sum lst (+ (length lst) 1) 1))
(setq ds (car(last lst)))
(loop
( cond ((eql sum_now sum_all) (return lst)) )
( cond ((eql ds 0) (return nil)) )
( cond ( (<= (+ sum_now ds) sum_all) (setq lst (append lst (list ds))) (setq sum_now (+ sum_now ds)) )
( 1 (setq ds (- ds 1)) )
)
)
)
Prototype:
% generated: 16-17 February 2005
% option(s):
%
% Resolution prover for first order logic
%
% Piter Protsyk (from Lisp version by R. P. Gabriel)
%
% Feb 2005
%
% prove theorem
% usage example:
%
% ?-translate( exists(x, p(x) & all(y,d(y)->l(x,y)))),
% translate( all(x, p(x)->all(y,q(y)-> ~l(x,y)))),
% translate( ~all(x,d(x)-> ~q(x))).
%
% % solve([exists(x,p(x)&all(y,d(y)->l(x,y))),all(x,p(x)->all(y,q(y)-> ~l(x,y))),~all(x,d(x)-> ~q(x))],R).
%
%
% 16-17/02/2005 (Piter Protsyk).
%
:- op(30,fx,~).
:- op(100,xfy,#).
:- op(100,xfy,&).
:- op(150,xfy,->).
:- op(150,xfy,<->).
make_vars(Term,VarTerm):-atom(Term),name(Term,Z),name(VarTerm,[65|Z]).
sh([],Term,Term1).
sh([X|Cs],Term,Term1):-sh(Cs,Term,Term1),subst(X,Z,Term,Term1).
find_resolventa([],L1).
find_resolventa([cl(A,B)|Cs],L1):-right(A,L1,L2),append(L1,L2,L),find_resolventa(Cs,L).
find_resolventa([cl(A,B)|Cs],L1):-left(B,L1,L2),append(L1,L2,L),find_resolventa(Cs,L).
right(A,[cl(C,B)|L1],L2):-try(A,B,B1),!,L2 = cl(C,B1).
right(A,[cl(C,B)|L1],L2):-right(A,L1,L2).
right(A,L1,[]).
left(A,[cl(C,B)|L1],L2):-try(A,C,B1),!,L2 = cl(B1,B).
left(A,[cl(C,B)|L1],L2):-left(A,L1,L2).
left(A,L1,[]).
try(A,[B|Cs],B1):-unify(A,B),B1=Cs,!.
try(A,[B|Cs],[B|Cs1]):-try(A,Cs,Cs1).
try(A,[],[]):-fail.
solve(X,Y):-translate_List(X,R),linilize(R,Y),pclauses(Y).
linilize([],[]).
linilize([X|L1],L2):-append(X,L,L2),linilize(L1,L).
translate_List([],[]).
translate_List([X|L],[Y|Rez]):-trans(X,Y),translate_List(L,Rez).
trans(X,Clauses) :-
implout(X,X1),
negin(X1,X2),
skolem(X2,X3,[]),
univout(X3,X4),
conjn(X4,X5),
clausify(X5,Clauses,[]).
translate(X) :-
implout(X,X1),
negin(X1,X2),
skolem(X2,X3,[]),
univout(X3,X4),
conjn(X4,X5),
clausify(X5,Clauses,[]),
pclauses(Clauses).
implout( (P <-> Q), (P1 & Q1) # (~P1 & ~Q1) ):-!,
implout(P,P1),
implout(Q,Q1).
implout( (P->Q), (~P1 # Q1)):-!,
implout(P,P1),
implout(Q,Q1).
implout( all(X,P), all(X,P1)) :- !, implout(P,P1).
implout( exists(X,P), exists(X,P1)) :-!, implout(P,P1).
implout( (P & Q), (P1 & Q1) ) :- !,
implout(P,P1),
implout(Q,Q1).
implout( (P # Q), (P1 # Q1) ) :- !,
implout(P,P1),
implout(Q,Q1).
implout( (~P), (~P1)) :- !, implout(P,P1).
implout(P,P).
negin( (~P), P1) :- !, neg(P,P1).
negin( all(X,P), all(X,P1)):- !, negin(P,P1).
negin( exists(X,P), exists(X,P1)) :- !, negin(P,P1).
negin( (P & Q), (P1 & Q1)) :- !, negin(P,P1), negin(Q,Q1).
negin( (P # Q), (P1 # Q1)) :- !, negin(P,P1), negin(Q,Q1).
negin( P, P).
neg( (~P), P1 ) :- !, negin(P,P1).
neg( all(X,P), exists(X,P1) ) :- !, neg(P,P1).
neg( (P & Q), (P1 # Q1) ) :- !, neg(P,P1), neg(Q,Q1).
neg( (P # Q), (P1 & Q1) ) :- !, neg(P,P1), neg(Q,Q1).
neg( P, (~P) ).
concat([],L,L).
concat([X|L1],L2,[X|L3]):- concat(L1,L2,L3).
gensym(Root, Atom) :-
gen_num(Root, Number),
name(Root,Name1),
nat_name(Number, Name2),
concat(Name1,Name2,Name),
name(Atom,Name).
gen_num(Root,Number) :-
retract( cur_number(Root,Number1) ), ! , Number is Number1 + 1,
asserta( cur_number(Root,Number) ).
gen_num(Root, 1) :- asserta( cur_number(Root,1) ).
nat_name(N, L) :- nat_name(N,[],L).
nat_name(I, CL, [C|CL] ) :- I<10, !, C is I+48.
nat_name(I, CL, L) :-
Dev is I // 10,
Ost is I mod 10,
C is Ost + 48,
nat_name(Dev,[C|CL],L).
constant(X):-atom(X).
constant(X):-integer(X).
subst(Old,New,Term,Term):-constant(Term),Term \= Old.
subst(Old,New,Term,Term1):-
compound(Term),
functor(Term,F,N),
functor(Term1,F,N),
subst(N,Old,New,Term,Term1).
subst(Old,New,Old,New).
subst(0,Old,New,Term,Term1).
subst(N,Old,New,Term,Term1):-
N>0,
arg(N,Term,Arg),
subst(Old,New,Arg,Arg1),
arg(N,Term1,Arg1),
N1 is N-1,
subst(N1,Old,New,Term,Term1).
skolem( all(X,P), all(X,P1), Vars) :- !, skolem(P,P1,[X|Vars]).
skolem( exists(X,P), P2, Vars) :- !,
gensym(f,F), Sk =.. [F|Vars],
subst(X,Sk,P,P1),
skolem(P1,P2,Vars).
skolem( (P # Q), (P1 # Q1), Vars ) :- !,
skolem(P,P1,Vars),
skolem(Q,Q1,Vars).
skolem( (P & Q), (P1 & Q1), Vars ) :- !,
skolem(P,P1,Vars),
skolem(Q,Q1,Vars).
skolem( P,P,_).
univout( all(X,P), P1) :- !, univout(P,P1).
univout( (P & Q), (P1 & Q1) ):- !,
univout(P,P1),
univout(Q,Q1).
univout( (P # Q), (P1 # Q1) ):-!,
univout(P,P1),
univout(Q,Q1).
univout(P,P).
conjn( (P # Q), R):- !,
conjn(P,P1),
conjn(Q,Q1),
conjn1( (P1 # Q1), R).
conjn( (P & Q), (P1 & Q1) ):- !,
conjn(P, P1),
conjn(Q, Q1).
conjn(P,P).
conjn1( ((P & Q) # R), (P1 & Q1)):-!,
conjn((P # Q), P1),
conjn((Q # R), Q1).
conjn1( (P # (Q & R)), (P1 & Q1)):-!,
conjn((P # Q), P1),
conjn((P # R), Q1).
conjn1(P,P).
clausify((P & Q), C1, C2):- !,
clausify(P,C1,C3),clausify(Q,C3,C2).
clausify(P,[cl(A,B)|Cs],Cs) :- inclause(P,A,[],B,[]),!.
clausify(_,C,C).
inclause( (P # Q),A,A1,B,B1):-!,
inclause(P,A2,A1,B2,B1),inclause(Q,A,A2,B,B2).
inclause( (~P),A,A,B1,B) :- !,
notin(P,A), putin(P,B,B1).
inclause(P,A1,A,B,B):-
notin(P,B),putin(P,A,A1).
notin(X,[X|_]) :- !,fail.
notin(X,[_|L]) :- !,notin(X,L).
notin(X,[]).
putin(X,[],[X]) :- !.
putin(X,[X|L],L):-!.
putin(X,[Y|L],[Y|L1]):-putin(X,L,L1).
pclauses([]):-!,nl,nl.
pclauses([cl(A,B)|Cs]):- pclause(A,B), nl, pclauses(Cs).
pclause(L,[]):-!, pdisj(L), write('.').
pclause([],L):-!, write(':-'), pconj(L), write('.').
pclause(L1,L2):- pdisj(L1),write(':-'),pconj(L2),write('.').
pdisj([L]) :-!, write(L).
pdisj([L|Ls]):- write(L), write(';'), pdisj(Ls).
pconj([L]) :-!, write(L).
pconj([L|Ls]):- write(L),write(','),pconj(Ls).
unify(X,Y):-var(X),var(Y),X=Y.
unify(X,Y):-var(X),nonvar(Y),not_occurs_in(X,Y),X=Y.
unify(X,Y):-var(Y),nonvar(X),not_occurs_in(X,Y),Y=X.
unify(X,Y):-nonvar(X),nonvar(Y),constant(Y),X=Y.
unify(X,Y):-nonvar(X),nonvar(Y),compound(X),compound(Y),term_unify(X,Y).
not_occurs_in(X,Y):-var(Y), X \== Y.
not_occurs_in(X,Y):-nonvar(Y),constant(Y).
not_occurs_in(X,Y):-nonvar(Y),compound(Y),functor(Y,F,N),not_occurs_in(N,X,Y).
not_occurs_in(N,X,Y):-
N>0,
arg(N,Y,Arg),
not_occurs_in(X,Arg),
N1 is N-1,
not_occurs_in(N1,X,Y).
not_occurs_in(0,X,Y).
term_unify(X,Y):-
functor(X,F,N),
functor(Y,F,N),
unify_args(N,X,Y).
unify_args(N,X,Y):-
N>0,
unify_arg(N,X,Y),
N1 is N-1,
unify_args(N1,X,Y).
unify_args(0,X,Y).
unify_arg(N,X,Y):-
arg(N,X,ArgX),
arg(N,Y,ArgY),
unify(ArgX,ArgY).
%%
% ?-translate( exists(x, p(x) & all(y,d(y)->l(x,y)))),
% translate( all(x, p(x)->all(y,q(y)-> ~l(x,y)))),
% translate( ~all(x,d(x)-> ~q(x))).
%
% usage example:
%
% solve([exists(x,p(x)&all(y,d(y)->l(x,y))),all(x,p(x)->all(y,q(y)-> ~l(x,y))),~all(x,d(x)-> ~q(x))],R).
%
%
% 16-17/02/2005 (Piter Protsyk).
%%
:- op(30,fx,~).
:- op(100,xfy,#).
:- op(100,xfy,&).
:- op(150,xfy,->).
:- op(150,xfy,<->).
solve(X,Y):-translate_List(X,R),linilize(R,Y),pclauses(Y).
linilize([],[]).
linilize([X|L1],L2):-append(X,L,L2),linilize(L1,L).
translate_List([],[]).
translate_List([X|L],[Y|Rez]):-trans(X,Y),translate_List(L,Rez).
trans(X,Clauses) :-
implout(X,X1),
negin(X1,X2),
skolem(X2,X3,[]),
univout(X3,X4),
conjn(X4,X5),
clausify(X5,Clauses,[]).
translate(X) :-
implout(X,X1),
negin(X1,X2),
skolem(X2,X3,[]),
univout(X3,X4),
conjn(X4,X5),
clausify(X5,Clauses,[]),
pclauses(Clauses).
implout( (P <-> Q), (P1 & Q1) # (~P1 & ~Q1) ):-!,
implout(P,P1),
implout(Q,Q1).
implout( (P->Q), (~P1 # Q1)):-!,
implout(P,P1),
implout(Q,Q1).
implout( all(X,P), all(X,P1)) :- !, implout(P,P1).
implout( exists(X,P), exists(X,P1)) :-!, implout(P,P1).
implout( (P & Q), (P1 & Q1) ) :- !,
implout(P,P1),
implout(Q,Q1).
implout( (P # Q), (P1 # Q1) ) :- !,
implout(P,P1),
implout(Q,Q1).
implout( (~P), (~P1)) :- !, implout(P,P1).
implout(P,P).
negin( (~P), P1) :- !, neg(P,P1).
negin( all(X,P), all(X,P1)):- !, negin(P,P1).
negin( exists(X,P), exists(X,P1)) :- !, negin(P,P1).
negin( (P & Q), (P1 & Q1)) :- !, negin(P,P1), negin(Q,Q1).
negin( (P # Q), (P1 # Q1)) :- !, negin(P,P1), negin(Q,Q1).
negin( P, P).
neg( (~P), P1 ) :- !, negin(P,P1).
neg( all(X,P), exists(X,P1) ) :- !, neg(P,P1).
neg( (P & Q), (P1 # Q1) ) :- !, neg(P,P1), neg(Q,Q1).
neg( (P # Q), (P1 & Q1) ) :- !, neg(P,P1), neg(Q,Q1).
neg( P, (~P) ).
concat([],L,L).
concat([X|L1],L2,[X|L3]):- concat(L1,L2,L3).
gensym(Root, Atom) :-
gen_num(Root, Number),
name(Root,Name1),
nat_name(Number, Name2),
concat(Name1,Name2,Name),
name(Atom,Name).
gen_num(Root,Number) :-
retract( cur_number(Root,Number1) ), ! , Number is Number1 + 1,
asserta( cur_number(Root,Number) ).
gen_num(Root, 1) :- asserta( cur_number(Root,1) ).
nat_name(N, L) :- nat_name(N,[],L).
nat_name(I, CL, [C|CL] ) :- I<10, !, C is I+48.
nat_name(I, CL, L) :-
Dev is I // 10,
Ost is I mod 10,
C is Ost + 48,
nat_name(Dev,[C|CL],L).
constant(X):-atom(X).
constant(X):-integer(X).
subst(Old,New,Term,Term):-constant(Term),Term \= Old.
subst(Old,New,Term,Term1):-
compound(Term),
functor(Term,F,N),
functor(Term1,F,N),
subst(N,Old,New,Term,Term1).
subst(Old,New,Old,New).
subst(0,Old,New,Term,Term1).
subst(N,Old,New,Term,Term1):-
N>0,
arg(N,Term,Arg),
subst(Old,New,Arg,Arg1),
arg(N,Term1,Arg1),
N1 is N-1,
subst(N1,Old,New,Term,Term1).
skolem( all(X,P), all(X,P1), Vars) :- !, skolem(P,P1,[X|Vars]).
skolem( exists(X,P), P2, Vars) :- !,
gensym(const,F), Sk =.. [F|Vars],
subst(X,Sk,P,P1),
skolem(P1,P2,Vars).
skolem( (P # Q), (P1 # Q1), Vars ) :- !,
skolem(P,P1,Vars),
skolem(Q,Q1,Vars).
skolem( (P & Q), (P1 & Q1), Vars ) :- !,
skolem(P,P1,Vars),
skolem(Q,Q1,Vars).
skolem( P,P,_).
univout( all(X,P), P1) :- !, univout(P,P1).
univout( (P & Q), (P1 & Q1) ):- !,
univout(P,P1),
univout(Q,Q1).
univout( (P # Q), (P1 # Q1) ):-!,
univout(P,P1),
univout(Q,Q1).
univout(P,P).
conjn( (P # Q), R):- !,
conjn(P,P1),
conjn(Q,Q1),
conjn1( (P1 # Q1), R).
conjn( (P & Q), (P1 & Q1) ):- !,
conjn(P, P1),
conjn(Q, Q1).
conjn(P,P).
conjn1( ((P & Q) # R), (P1 & Q1)):-!,
conjn((P # Q), P1),
conjn((Q # R), Q1).
conjn1( (P # (Q & R)), (P1 & Q1)):-!,
conjn((P # Q), P1),
conjn((P # R), Q1).
conjn1(P,P).
clausify((P & Q), C1, C2):- !,
clausify(P,C1,C3),clausify(Q,C3,C2).
clausify(P,[cl(A,B)|Cs],Cs) :- inclause(P,A,[],B,[]),!.
clausify(_,C,C).
inclause( (P # Q),A,A1,B,B1):-!,
inclause(P,A2,A1,B2,B1),inclause(Q,A,A2,B,B2).
inclause( (~P),A,A,B1,B) :- !,
notin(P,A), putin(P,B,B1).
inclause(P,A1,A,B,B):-
notin(P,B),putin(P,A,A1).
notin(X,[X|_]) :- !,fail.
notin(X,[_|L]) :- !,notin(X,L).
notin(X,[]).
putin(X,[],[X]) :- !.
putin(X,[X|L],L):-!.
putin(X,[Y|L],[Y|L1]):-putin(X,L,L1).
pclauses([]):-!,nl,nl.
pclauses([cl(A,B)|Cs]):- pclause(A,B), nl, pclauses(Cs).
pclause(L,[]):-!, pdisj(L), write('.').
pclause([],L):-!, write(':-'), pconj(L), write('.').
pclause(L1,L2):- pdisj(L1),write(':-'),pconj(L2),write('.').
pdisj([L]) :-!, write(L).
pdisj([L|Ls]):- write(L), write(';'), pdisj(Ls).
pconj([L]) :-!, write(L).
pconj([L|Ls]):- write(L),write(','),pconj(Ls).
unify(X,Y):-var(X),var(Y),X=Y.
unify(X,Y):-var(X),nonvar(Y),not_occurs_in(X,Y),X=Y.
unify(X,Y):-var(Y),nonvar(X),not_occurs_in(X,Y),Y=X.
unify(X,Y):-nonvar(X),nonvar(Y),constant(Y),X=Y.
unify(X,Y):-nonvar(X),nonvar(Y),compound(X),compound(Y),term_unify(X,Y).
not_occurs_in(X,Y):-var(Y), X \== Y.
not_occurs_in(X,Y):-nonvar(Y),constant(Y).
not_occurs_in(X,Y):-nonvar(Y),compound(Y),functor(Y,F,N),not_occurs_in(N,X,Y).
not_occurs_in(N,X,Y):-
N>0,
arg(N,Y,Arg),
not_occurs_in(X,Arg),
N1 is N-1,
not_occurs_in(N1,X,Y).
not_occurs_in(0,X,Y).
term_unify(X,Y):-
functor(X,F,N),
functor(Y,F,N),
unify_args(N,X,Y).
unify_args(N,X,Y):-
N>0,
unify_arg(N,X,Y),
N1 is N-1,
unify_args(N1,X,Y).
unify_args(0,X,Y).
unify_arg(N,X,Y):-
arg(N,X,ArgX),
arg(N,Y,ArgY),
unify(ArgX,ArgY).
%%
% ?-translate( exists(x, p(x) & all(y,d(y)->l(x,y)))),
% translate( all(x, p(x)->all(y,q(y)-> ~l(x,y)))),
% translate( ~all(x,d(x)-> ~q(x))).
%
% usage example:
%
% solve([exists(x,p(x)&all(y,d(y)->l(x,y))),all(x,p(x)->all(y,q(y)-> ~l(x,y))),~all(x,d(x)-> ~q(x))],R).
%
%
% 16-17/02/2005 (Piter Protsyk).
%%
:- op(30,fx,~).
:- op(100,xfy,#).
:- op(100,xfy,&).
:- op(150,xfy,->).
:- op(150,xfy,<->).
solve(X,Y):-translate_List(X,R),linilize(R,Y),pclauses(Y).
linilize([],[]).
linilize([X|L1],L2):-append(X,L,L2),linilize(L1,L).
translate_List([],[]).
translate_List([X|L],[Y|Rez]):-trans(X,Y),translate_List(L,Rez).
trans(X,Clauses) :-
implout(X,X1),
negin(X1,X2),
skolem(X2,X3,[]),
univout(X3,X4),
conjn(X4,X5),
clausify(X5,Clauses,[]).
translate(X) :-
implout(X,X1),
negin(X1,X2),
skolem(X2,X3,[]),
univout(X3,X4),
conjn(X4,X5),
clausify(X5,Clauses,[]),
pclauses(Clauses).
implout( (P <-> Q), (P1 & Q1) # (~P1 & ~Q1) ):-!,
implout(P,P1),
implout(Q,Q1).
implout( (P->Q), (~P1 # Q1)):-!,
implout(P,P1),
implout(Q,Q1).
implout( all(X,P), all(X,P1)) :- !, implout(P,P1).
implout( exists(X,P), exists(X,P1)) :-!, implout(P,P1).
implout( (P & Q), (P1 & Q1) ) :- !,
implout(P,P1),
implout(Q,Q1).
implout( (P # Q), (P1 # Q1) ) :- !,
implout(P,P1),
implout(Q,Q1).
implout( (~P), (~P1)) :- !, implout(P,P1).
implout(P,P).
negin( (~P), P1) :- !, neg(P,P1).
negin( all(X,P), all(X,P1)):- !, negin(P,P1).
negin( exists(X,P), exists(X,P1)) :- !, negin(P,P1).
negin( (P & Q), (P1 & Q1)) :- !, negin(P,P1), negin(Q,Q1).
negin( (P # Q), (P1 # Q1)) :- !, negin(P,P1), negin(Q,Q1).
negin( P, P).
neg( (~P), P1 ) :- !, negin(P,P1).
neg( all(X,P), exists(X,P1) ) :- !, neg(P,P1).
neg( (P & Q), (P1 # Q1) ) :- !, neg(P,P1), neg(Q,Q1).
neg( (P # Q), (P1 & Q1) ) :- !, neg(P,P1), neg(Q,Q1).
neg( P, (~P) ).
concat([],L,L).
concat([X|L1],L2,[X|L3]):- concat(L1,L2,L3).
gensym(Root, Atom) :-
gen_num(Root, Number),
name(Root,Name1),
nat_name(Number, Name2),
concat(Name1,Name2,Name),
name(Atom,Name).
gen_num(Root,Number) :-
retract( cur_number(Root,Number1) ), ! , Number is Number1 + 1,
asserta( cur_number(Root,Number) ).
gen_num(Root, 1) :- asserta( cur_number(Root,1) ).
nat_name(N, L) :- nat_name(N,[],L).
nat_name(I, CL, [C|CL] ) :- I<10, !, C is I+48.
nat_name(I, CL, L) :-
Dev is I // 10,
Ost is I mod 10,
C is Ost + 48,
nat_name(Dev,[C|CL],L).
constant(X):-atom(X).
constant(X):-integer(X).
subst(Old,New,Term,Term):-constant(Term),Term \= Old.
subst(Old,New,Term,Term1):-
compound(Term),
functor(Term,F,N),
functor(Term1,F,N),
subst(N,Old,New,Term,Term1).
subst(Old,New,Old,New).
subst(0,Old,New,Term,Term1).
subst(N,Old,New,Term,Term1):-
N>0,
arg(N,Term,Arg),
subst(Old,New,Arg,Arg1),
arg(N,Term1,Arg1),
N1 is N-1,
subst(N1,Old,New,Term,Term1).
skolem( all(X,P), all(X,P1), Vars) :- !, skolem(P,P1,[X|Vars]).
skolem( exists(X,P), P2, Vars) :- !,
gensym(const,F), Sk =.. [F|Vars],
subst(X,Sk,P,P1),
skolem(P1,P2,Vars).
skolem( (P # Q), (P1 # Q1), Vars ) :- !,
skolem(P,P1,Vars),
skolem(Q,Q1,Vars).
skolem( (P & Q), (P1 & Q1), Vars ) :- !,
skolem(P,P1,Vars),
skolem(Q,Q1,Vars).
skolem( P,P,_).
univout( all(X,P), P1) :- !, univout(P,P1).
univout( (P & Q), (P1 & Q1) ):- !,
univout(P,P1),
univout(Q,Q1).
univout( (P # Q), (P1 # Q1) ):-!,
univout(P,P1),
univout(Q,Q1).
univout(P,P).
conjn( (P # Q), R):- !,
conjn(P,P1),
conjn(Q,Q1),
conjn1( (P1 # Q1), R).
conjn( (P & Q), (P1 & Q1) ):- !,
conjn(P, P1),
conjn(Q, Q1).
conjn(P,P).
conjn1( ((P & Q) # R), (P1 & Q1)):-!,
conjn((P # Q), P1),
conjn((Q # R), Q1).
conjn1( (P # (Q & R)), (P1 & Q1)):-!,
conjn((P # Q), P1),
conjn((P # R), Q1).
conjn1(P,P).
clausify((P & Q), C1, C2):- !,
clausify(P,C1,C3),clausify(Q,C3,C2).
clausify(P,[cl(A,B)|Cs],Cs) :- inclause(P,A,[],B,[]),!.
clausify(_,C,C).
inclause( (P # Q),A,A1,B,B1):-!,
inclause(P,A2,A1,B2,B1),inclause(Q,A,A2,B,B2).
inclause( (~P),A,A,B1,B) :- !,
notin(P,A), putin(P,B,B1).
inclause(P,A1,A,B,B):-
notin(P,B),putin(P,A,A1).
notin(X,[X|_]) :- !,fail.
notin(X,[_|L]) :- !,notin(X,L).
notin(X,[]).
putin(X,[],[X]) :- !.
putin(X,[X|L],L):-!.
putin(X,[Y|L],[Y|L1]):-putin(X,L,L1).
pclauses([]):-!,nl,nl.
pclauses([cl(A,B)|Cs]):- pclause(A,B), nl, pclauses(Cs).
pclause(L,[]):-!, pdisj(L), write('.').
pclause([],L):-!, write(':-'), pconj(L), write('.').
pclause(L1,L2):- pdisj(L1),write(':-'),pconj(L2),write('.').
pdisj([L]) :-!, write(L).
pdisj([L|Ls]):- write(L), write(';'), pdisj(Ls).
pconj([L]) :-!, write(L).
pconj([L|Ls]):- write(L),write(','),pconj(Ls).
unify(X,Y):-var(X),var(Y),X=Y.
unify(X,Y):-var(X),nonvar(Y),not_occurs_in(X,Y),X=Y.
unify(X,Y):-var(Y),nonvar(X),not_occurs_in(X,Y),Y=X.
unify(X,Y):-nonvar(X),nonvar(Y),constant(Y),X=Y.
unify(X,Y):-nonvar(X),nonvar(Y),compound(X),compound(Y),term_unify(X,Y).
not_occurs_in(X,Y):-var(Y), X \== Y.
not_occurs_in(X,Y):-nonvar(Y),constant(Y).
not_occurs_in(X,Y):-nonvar(Y),compound(Y),functor(Y,F,N),not_occurs_in(N,X,Y).
not_occurs_in(N,X,Y):-
N>0,
arg(N,Y,Arg),
not_occurs_in(X,Arg),
N1 is N-1,
not_occurs_in(N1,X,Y).
not_occurs_in(0,X,Y).
term_unify(X,Y):-
functor(X,F,N),
functor(Y,F,N),
unify_args(N,X,Y).
unify_args(N,X,Y):-
N>0,
unify_arg(N,X,Y),
N1 is N-1,
unify_args(N1,X,Y).
unify_args(0,X,Y).
unify_arg(N,X,Y):-
arg(N,X,ArgX),
arg(N,Y,ArgY),
unify(ArgX,ArgY).