Приложение 2. /* Основные и служебные базы данных */

DOMAINS

toch=string

km,ml=real

Int=integer

slist=string*

sslist=slist*

rlist=real*

/* Основные и служебные базы данных */

DATABASE - sosed

sosed(toch,toch,km,ml)

DATABASE - lists

lists(slist)

DATABASE - sum

sum(real)

PREDICATES

connect(toch,toch,km,ml,slist,slist)

wopros

start

autoload

working(Int)

main_menu

par(toch,toch,Int)

repeat

find(string,slist)

add(slist,string,slist)

result(slist,slist,slist)

adds(slist)

writelist(slist)

min(rlist,real,integer,integer,real,integer)

createSum(real,real)

summa(slist,real,real,real,real)

dcon(toch,toch,real,real)

createListR(rlist,rlist)

addr(rlist,real,rlist)

createListS(sslist,sslist)

addss(sslist,slist,sslist)

first(rlist,real)

writeN(sslist,integer)

writeall(sslist)

GOAL start.

CLAUSES

writelist([]).

writelist([X|L]):-write(" ",X), writelist(L).

dcon(X,Y,M,N):- sosed(X,Y,M,N);sosed(Y,X,M,N).

summa([_],N,S,_,_):- S=N.

summa([X,Y|L],N,S,Км,Бензин):-bound(Км),dcon(X,Y,M,_), K=M+N, summa([Y|L],K,S,Км,Бензин);

bound(Бензин), dcon(X,Y,_,M), K=M+N, summa([Y|L],K,S,Км,Бензин).

add(L1,S,[S|L1]).

adds(X):- lists(X),!.

adds(X):- assertz(lists(X)).

createSum(Км,Бензин):- lists(X), summa(X,0,Suma,Км,Бензин),

assertz(sum(Suma)), fail.

createSum(_,_).

addr(L1,R,[R|L1]).

createListR(R,L):- not (sum(_)), R=L.

createListR(R,L):- sum(X),

addr(L,X,M),retract(sum(X)),createListR(R,M).

addss(L1,R,[R|L1]).

createListS(R,L):- not (lists(_)), R=L.

createListS(R,L):- lists(X), addss(L,X,M), retract(lists(X)),

createListS(R,M).

first([X|_],N):- N=X.

min([],Tmp,Cnt,_,Min,N):- Min=Tmp, N=Cnt.

min([X|L],Tmp,Cnt,K,Min,N):- Tmp>X, C=K, KK=K+1, MM=X,

min(L,MM,C,KK,Min,N);

KK=K+1, min(L,Tmp,Cnt,KK,Min,N).

writeN([L|_],0):- writelist(L).

writeN([_|L],N):- M=N-1, writeN(L,M).

find(R,[R|_]).

find(R,[_|T]):- find(R,T).

result([_],L,R):- R=L.

result([X|L],M,R):- add(M,X,L1), result(L,L1,R).

writeall([]).

writeall([X|L]):- writelist(X), nl, writeall(L).

/* Основная процедура start */

start:-

autoload,

main_menu.

% Процедура connect

connect(X,Y,_,_,M,R):-

sosed(X,Y,AA,BB), R=M;

sosed(Y,X,AA,BB), R=M.

connect(X,Y,Км,Бензин,L,R):-

sosed(X,Z,_,_),

not (find(Z,L)), add(L,Z,M), connect(Z,Y,Км,Бензин,M,R);

sosed(Z,X,_,_),

not (find(Z,L)), add(L,Z,M),

connect(Z,Y,Км,Бензин,M,R).

par(X,Y,'1'):-removewindow(15,1),L=[X,Y],connect(X,Y,_,_,L,R),

result(R,[Y],M), adds(M), fail.

par(_,_,'1'):- not(lists(_)), write("НЕТ ПУТИ").

par(_,_,'1'):-createSum(0,_), createListR(L1,[]), first(L1,Z),

min(L1,Z,0,0,M,N), write("Минимальное расстояние = ",M,"км."),createListS(R,[]),

nl,write("Траектория пути - "),writeN(R,N).

par(X,Y,'2'):- removewindow(15,1),L=[X,Y],connect(X,Y,_,_,L,R),

result(R,[Y],M), adds(M), fail.

par(_,_,'2'):- not(lists(_)), write("НЕТ ПУТИ").

par(_,_,'2'):-createSum(_,0), createListR(L1,[]), first(L1,Z),

min(L1,Z,0,0,M,N), write("Минимальный расход бензина = ",M," мл."),

createListS(R,[]),nl, write(" Траектория пути - "),writeN(R,N).

par(X,Y,'3'):- removewindow(15,1),L=[X,Y], connect(X,Y,_,_,L,R),

result(R,[Y],M), adds(M),fail.

par(_,_,'3'):- not(lists(_)),write("НЕТ РЕШЕНИЙ").

par(_,_,'3'):- write("Все маршруты:"),nl,createListS(R,[]),writeall(R).

% Процедура wopros

wopros:-

retractall(_,lists),

retractall(_,sum),

write("Ищем путь с параметрами"),nl,

write("От"),nl,readln(X),write("До"),nl,readln(Y),

makewindow(15,$1E,$2F," ВВОД ПАРАМЕТРОВ ",6,18,9,40),

write(" 1 - Расстояние"),nl,

write(" 2 - Расход бензина"),nl,

write(" 3 - Все пути"),nl,

write(" ->"),

readchar(N),

clearwindow,

par(X,Y,N),

removewindow(15,0).

wopros:- removewindow(15,0).

/* Процедура автоматической загрузки баз данных */

autoload:-

retractall(_,sosed),

consult("pal.ddd",sosed).

autoload:-

makewindow(2,74,79,"ОШИБКА",6,18,8,40),

cursor(2,10),

write("Нет базы на диске"),

sound(70,294),

removewindow,

!.

/* Главное меню */

main_menu:-

repeat,

makewindow(1,$1E,$2F,"ТРАЕКТОРИЯ ПУТИ РАЗНОСЧИКА ПИЦЦЫ",0,0,25,80),cursor(7,0),

write(" 1 - Сохранение базы"),nl,

write(" 2 - Добавление пункта доставки"),nl,

write(" 3 - Удаление пункта доставки"),nl,

write(" 4 - Просмотр базы"),nl,

write(" 5 - Решение задачи"),nl,

write(" 6 - Выход из программы"),nl,

write(" ->"),

readint(C),

clearwindow,

working(C),

clearwindow,

C = 6,

retractall(_),

removewindow(1,0).

/* Процедура сохранения базы данных */

working(1):-

makewindow(5,$5F,$5F," СОХРАНЕНИЕ БАЗЫ ",8,20,9,40),

sound(5,220),

repeat,

save("pal.ddd",sosed),nl,nl,

write(" База сохранена"),nl,nl,nl,

write(" Нажмите любую клавишу..."),nl,

readchar(_),

clearwindow,

!,

removewindow.

/* Процедура Добавления связей */

working(2):-

makewindow(6,$1E,$2F," ДОБАВЛЕНИЕ ПУНКТА ДОСТАВКИ ",0,0,25,80),

sound(5,220),

cursor(9,0),

write(" введите имя 1 пункта ->"),readln(P1),

write(" введите имя 2 пункта ->"),readln(P2),

write(" введите расстояние (в км.) ->"),readreal(Км),

write(" введите расход бензина (в мл.) ->"),readint(Бензин),

assertz(sosed(P1,P2,Км,Бензин)),

clearwindow,!,

removewindow(6,0).

/* Процедура Удаление связей */

working(3):-

makewindow(7,26,$4F," УДАЛЕНИЕ ПУНКТА ДОСТАВКИ ",0,0,25,80),

sound(5,220),

cursor(9,0),

write(" Bведите имя 1 пункта ->"),nl,

readln(P1),

write(" Bведите имя 2 пункта ->"),nl,readln(P2),

retract(sosed(P1,P2,_,_)),

clearwindow,

!,removewindow.

/* Процедуры просмотра баз данных */

working(4):-

makewindow(9,$1E,$2F," ПРОСМОТР БАЗЫ ДАННЫХ ",0,0,25,80),nl,

write(" г=============================================================="),nl,

write(" ¦ База данных ¦"),nl,

write(" ¦==============T=============T============T====================¦"),nl,

write(" ¦ Пункт #1 ¦ Пункт #2 ¦ Расстояние ¦ Расход бензина ¦"),nl,

write(" ¦ ¦ ¦ ¦ ¦"),nl,

write(" ¦==============+=============+============+====================¦"),nl,

sosed(P1,P2,Км,Бензин),cursor(Z,_),

cursor(Z,0),write(" ¦ ",P1),

cursor(Z,15),write(" ¦ ",P2),

cursor(Z,29),write(" ¦ ",Км),

cursor(Z,42),write(" ¦ ",Бензин),

cursor(Z,63),write(" ¦"),nl,fail.

working(4):-

write(" L==============¦=============¦============¦====================-"),

nl,cursor(22,26),

write("Нажмите на любую клавишу"),

readchar(_),

removewindow,!.

% Процедура решения задачи

working(5) if

makewindow(10,26,48,"Решение задачи",0,0,25,80),

nl,nl,

sound (5,220),wopros,sound(5,220),

cursor(22,26),

write("Нажмите на любую клавишу"),

readchar(_),

removewindow(10,1),!.

/* Процедура выхода из программы */

working(6):- removewindow(1,1).

working(_):-

makewindow(11,$4E,$4F,"ОШИБКА ВВОДА",6,18,8,40),

nl,

write(" Введите число от 0 до 6,"),nl,

write(" соответствующее выбранному пункту"),nl,nl,nl,

write(" Нажмите на любую клавишу"),

sound(20,494),

sound(30,392),

readchar(_),

removewindow(11,1).

/* Процедура repeat */

repeat.

repeat:- repeat.