Пример 14.17. Правило print-result

(defrule print-result

(print-results)

?f <- (result $?input ?response)

(not (result $?input-2 ?response-2&:

(< (str-compare ?response-2 ?response) 0) ) )

=>

(retract ?f)

(while (neq ?input (create$)) do

(printout t " " (nth 1 ?input) " ")

(bind ?input (rest$ ?input)))

(printout t " | ")

(bind ?response (str-explode ?response))

(while (neq ?response (create$)) do

(printout t " " (nth 1 ?response) " ")

(bind ?response (rest$ ?response)))

(printout t crlf)

)

Правило print-result выводит на экран оптимизированную таблицу истинности, сортируя при этом ее строки.

Листинг программы

Разработку экспертной системы CIOS можно считать завершенной. Данный раздел содержит полный листинг программы с подробными комментариями. Если у вас еще не сложилась целостная картина, как работает эксперт­ная система CIOS, из каких частей она состоит, внимательно изучите приведенный код.

Пример 14.18. Полный листинг программы

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

; Пример экспертной системы на языке CLIPS

;

; Приведенная ниже экспертная система способна находить

; и оптимизировать таблицы истинности заданных логических схем.

;

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

; Необходимые классы

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс COMPONENT является суперклассом для всех классов логических элементов

(defclass COMPONENT

(is-a USER)

(slot ID# (create-accessor write))

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс NO-OUTPUT реализует логику работы элемента без логических выходов

(defclass NO-OUTPUT

(is-a USER)

(slot number-of-outputs (access read-only)

(default 0)

(create-accessor read))

)

; Предварительное объявление обработчика, осуществляющего обработку полученного сигнала

(defmessage-handler NO-OUTPUT compute-output ())

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс ONE-OUTPUT реализует логику работы элемента с одним логическим выходом

(defclass ONE-OUTPUT

(is-a NO-OUTPUT)

(slot number-of-outputs (access read-only)

(default 1)

(create-accessor read))

; значение выхода

(slot output-1 (default UNDEFINED)

(create-accessor write))

; название элемента, с которым связан выход

(slot output-1-link (default GROUND)

(create-accessor write))

; номер входа, с которым связан выход

(slot output-1-link-pin (default 1)

(create-accessor write))

)

; Обработчик для передачи обработанного сигнала на вход следующего элемента

(defmessage-handler ONE-OUTPUT put-output-1 after (?value)

(send ?self:output-1-link

(sym-cat put-input- ?self:output-l-link-pin)

?value)

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс TWO-OUTPUT реализует логику работы элемента с двумя логическими выходами

(defclass TWO-OUTPUT

(is-a ONE-OUTPUT)

(slot number-of-outputs (access read-only)

(default 2)

(create-accessor read) )

; значение выхода

(slot output-2 (default UNDEFINED)

(create-accessor write) )

; название элемента, с которым связан выход

(slot output-2-link (default GROUND)

(create-accessor write) )

; номер входа, с которым связан выход

(slot output-2-link-pin (default 1)

(create-accessor write) )

)

; Обработчик для передачи обработанного сигнала на вход следующего элемента

(defmessage-handler TWO-OUTPUT put-output-2 after (?value)

(send ?self: output-2-link

(sym-cat put-input- ?self: output-2-link-pin)

?value)

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс NO-INPUT реализует логику работы элемента без логических входов

(defclass NO-INPUT

(is-a USER)

(slot number-of-inputs (access read-only)

(default 0)

(create-accessor read) )

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс ONE-INPUT реализует логику работы элемента с одним логическим входом

(defclass ONE-INPUT

(is-a NO- INPUT)

(slot number-of-inputs (access read-only)

(default 1)

(create-accessor read) )

; значение входа

(slot input-1 (default UNDEFINED)

(visibility public)

(create-accessor read-write) )

; название элемента, с которым связан вход

(slot input-1-link (default GROUND)

(create-accessor write) )

;номер выхода, с которым связан вход

(slot input-1-link-pin (default 1)

(create-accessor write)) )

; Обработчик, активизирующий процесс вычисления результата работы схемы

; после изменения данного входа

(defmessage-handler ONE-INPUT put-input-1 after (?value)

(send ?self compute-output)

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс TWO-INPUT реализует логику работы элемента с двумя логическими входами

(defclass TWO-INPUT

(is-a ONE-INPUT)

(slot number-of-inputs (access read-only)

(default 2}

(create-accessor read))

; значение входа

(slot input-2 (default UNDEFINED)

(visibility public)

(create-accessor write))

; название элемента, с которым связан вход

(slot input-2-link (default GROUND)

(create-accessor write))

; номер выхода, с которым связан вход

(slot input-2-link-pin (default 1)

(create-accessor write))

)

; Обработчик, активизирующий процесс вычисления результата работы схемы

; после изменения данного входа

(defmessage-handler TWO-INPUT put-input-2 after (?value)

(send ?self compute-output)

)

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

; Классы, реализующие логические элементы

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс, реализующий логику работы элемента SOURCE, имеет один выход и не имеет входов

(defclass SOURCE

(is-a NO-INPUT ONE-OUTPUT COMPONENT)

(role concrete)

(slot output-1 (default UNDEFINED)

(create-accessor write))

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс, реализующий логику работы элемента LED, имеет один вход и не имеет выходов

(defclass LED

(is-a ONE-INPUT NO-OUTPUT COMPONENT)

(role concrete)

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс, реализующий логику работы элемента NOT, имеет один вход и один выход

(defclass NOT-GATE

(is-a ONE-INPUT ONE-OUTPUT COMPONENT)

(role concrete)

)

; Функция, вычисляющая значение элемента NOT в зависимости от полученного аргумента

(deffunctiori not# (?x) (- 1 ?х) )

; Обработчик, выполняющий вычисления элемента NOT при изменении входных сигналов

(defmessage-handler NOT-GATE compute-output ()

(if (integerp ?self:input-1) then

(send ?self put-output-1 (not# ?self:input-1)))

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс, реализующий логику работы элемента AND, имеет два входа и один выход

(defclass AND-GATE

(is-a TWO-INPUT ONE-OUTPUT COMPONENT)

(role concrete)

)

; Функция, вычисляющая значение элемента AND в зависимости от полученного аргумента (deffunction and! (?x ?y)

(if (and (! = ?х 0) (!= ?у 0)) then 1 else 0))

; Обработчик, выполняющий вычисления элемента AND при изменении входных сигналов (defmessage-handler AND-GATE compute-output ()

(if (and (integerp ?self:input-1)

(integerp ?self:input-2)) then

(send ?self put-output-1

(and# ?self:input-1 ?self:input-2)))

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс, реализующий логику работы элемента OR, имеет два входа и один выход

(defclass OR-GATE

(is-a TWO- INPUT ONE-OUTPUT COMPONENT)

(role concrete)

)

; Функция, вычисляющая значение элемента OR в зависимости от полученного аргумента

(deffunction or# (?x ?y)

(if (or (!= ?х 0) (I- ?y 0)) then 1 else 0))

; Обработчик, выполняющий вычисления элемента OR при изменении входных сигналов

(defmessage-handler OR-GATE compute-output ()

(if (and (integerp ?self : input-1)

(integerp ?self : input-2) ) then

(send ?self put-output-1

(or# ?self : input-1 ?self: input-2) ))

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс, реализующий логику работы элемента NAND, имеет два входа и один выход

(defclass NAND-GATE

(is-a TWO-INPUT ONE-OUTPUT COMPONENT)

(role concrete)

)

; Функция, вычисляющая значение элемента NAND в зависимости от полученного аргумента

(deffunction nand# (?x ?y)

(if (not (and (!= ?x 0) (!= ?y 0») then 1 else 0))

; Обработчик, выполняющий вычисления элемента NAND при изменении входных сигналов

(defmessage-handler NAND-GATE compute-output ()

(if (and (integerp ?self: input-1)

(integerp ?self: input-2) ) then

(send ?self put-output-1

(nand# ?self: input-1 ?self: input-2) ))

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс,реализующий логику работы элемента XOR, имеет два входа и один выход

(defclass XOR-GATE

(is-a TWO- INPUT ONE-OUTPUT COMPONENT)

(role concrete)

)

; Функция, вычисляющая значение элемента XOR в зависимости от полученного аргумента

(deffunction xor# (?x ?y)

(if (or (and (= ?x 1) (= ?y 0))

(and (= ?x 0} (= ?y 1))) then 1 else 0))

; Обработчик, выполняющий вычисления элемента XOR при изменении входных сигналов

(defmessage-handler XOR-GATE compute-output (}

(if (and (integerp ?self : input-1)

(integerp ?self : input-2) ) then

(send ?self put-output-1

(xor# ?self: input-1 ?self: input-2) ))

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Класс, реализующий логику работы элемента SPLITTER, имеет один вход и два выхода

(defclass SPLITTER

(is-a ONE-INPUT TWO-OUTPUT COMPONENT)

(role concrete)

)

; Обработчик, выполняющий вычисления элемента SPLITTER при изменении входных сигналов

(defmessage-handler SPLITTER compute-output ()

(if (integerp ?self: input-1) then

(send ?self put-output-1 ?self: input-1)

(send ?self put-output-2 ?self: input-1) )

)

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

; Методы родовой функции

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Предварительное объявление родовой функции

(defgeneric connect)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Соединение элемента, имеющего один выход, с элементом, имеющим один вход

(defmethod connect ((?out ONE-OUTPUT) (?in ONE-INPUT))

(send ?out put-output-1-link ?in)

(send ?out put-output-1-link-pin 1)

(send ?in put-input-1-link ?out)

(send ?in put-input-1-link-pin 1)

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Соединение элемента, имеющего один выход, с элементом, имеющим два входа

(defmethod connect ((?out ONE-OUTPUT) (?in TWO- INPUT) (?in-pin INTEGER))

(send ?out put-output-1-link ?in)

(send ?out put-output-1-link-pin ?in-pin)

(send ?in (sym-cat put-input- ?in-pin -link) ?out)

(send ?in (sym-cat put-input- ?in-pin -link-pin) 1)

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Соединение элемента, имеющего два выхода, с элементом, имеющим один вход

(defmethod connect ((?out TWO-OUTPUT) (?out-pin INTEGER) (?in ONE-INPUT)

(send ?out (sym-cat put-output- ?out-pin -link) ?in)

(send ?out (sym-cat put-output- ?out-pin -link-pin) 1)

(send ?in put-input-1-link ?out)

(send ?in put-input-1-link-pin ?out-pin)

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Соединение элемента, имеющего два выхода, с элементом, имеющим два входа

(defmethod connect ((?out TWO-OUTPUT) (?out-pin INTEGER)(?in TWO- INPUT) (?in-pin INTEGER))

(send ?out (sym-cat put-output- ?out-pin -link) ?in)

(send ?out (sym-cat put-output- ?out-pin -link-pin) ?in-pin)

(send ?in (sym-cat put-input- ?in-pin -link) ?out)

(send ?in (sym-cat put-input- ?in-pin -link-pin) ?out-pin)

)

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = == = = = = = = = = = = = = = = = =

; Глобальные переменные

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = == = = = = = = = = = = = = = = = =

(defglobal ?*gray-code* = (create$) ; Переменная для хранения текущего кода Грея

?*sources* = (create$) ; Список источников текущей логической схемы

?*max-iterations* = 0) ; Максимальное число итераций для текущей логической схемы

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = == = = = = = = = = = = = = = = = =

; Вспомогательные функции

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = == = = = = = = = = = = = = = = = =

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Определяет номер сигнала, который необходимо изменить для получения

; следующего кода Грея

(deffunction change-which-bit (?x)

(bind ?i 1)

(while (and (evenp ?x) (!= ?x 0)) do

(bind ?x (div ?x 2) )

(bind ?i (+ ?i 1) )

)

?i

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; С помощью функции do-for-all-instances определяет обработанный сигнал с индикаторов

; логической схемы

(def function LED- response ()

(bind ? response (create$) )

(do-for-all-instances ( (?led LED) ) TRUE

(bind ?response (create$ ?response

(send ?led get-input-1) ) ) )

?response

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Предварительное объявление функции, необходимой для объединения элементов

; логической схемы

deffunction connect-circuit ())

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = == = = = = = = = = = = = = = = = =

; Правила

;= = = = = = = = = = = = = = = = = = = = = = = = = = = = == = = = = = = = = = = = = = = = =

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Инициализация логической схемы и запуск системы

(defrule startup

=>

; инициализация текущей логической схемы

(connect-circuit)

; получение имен всех источников текущей логической схемы

(bind ?*sources* (find-all-instances ((?х SOURCE)) TRUE))

; создает нулевой код Грея

(do-for-all-instances ((?x SOURCE)) TRUE

(bind ?*gray-code* (create$ ?*gray-code* 0)))

; определение максимального числа итераций

(bind ?*max-iterations* (round (** 2 (length ?*sources*))

; обнуление количества сделанных итераций

(assert (current-iteration 0))

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Запуск процесса перебора всевозможных входных сигналов текущей логической системы

(defrule compute-response-1st-time

; если это первая итерация, то

?f <- (current-iteration 0)

=>

; помещение во все источники нулевого сигнала

(do-for-all-instances ((?source SOURCE)) TRUE

(send ?source put-output-1 0))

; получение результата работы логической схемы

(assert (result ?*gray-code* =(str-implode (LED-response))))

; увеличение количества итераций на 1

(retract ?f)

(assert (current-iteration 1))

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Перебор всевозможных входных сигналов текущей логической системы

(defrule compute-response-other-times

; если это не первая итерация и количество итераций еще не превышено

?f <- (current-iteration ?n&~0&:(< ?n ?*max-iterations*))

=>

; вычисление номера источника, сигнал которого нужно менять

(bind ?pos (change-which-bit ?n))

; получение следующего кода Грея

(bind ?nv (- 1 (nth ?pos ?*gray-code*)))

(bind ?*gray-code* (replace$ ?*gray-code* ?pos ?pos ?nv))

; изменение сигнала на заданном источнике на противоположный

(send (nth ?pos ?*sources*) put-output-1 ?nv)

; получение результата работы логической схемы

(assert (result ?*gray-code* =(str-implode (LED-response))))

; увеличение количества итераций на 1

(retract ?f)

(assert (current-iteration = ( + ?n 1) ) )

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Оптимизация таблицы истинности

(defrule merge-responses

; более высокий приоритет позволяет производить оптимизацию

; в процессе построения таблицы истинности

(declare (salience 10))

; если в текущей таблице есть две строки, которые можно объединить

?fl <- (result $?b ?x $?e ?response)

?f2 <- (result $?b ~?x $?e ?response)

=>

; то удалить такие строки

(retract ?fl ?f2)

; и вставить обобщенную строку

(assert (result ?b * ?е ?response) )

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Вывод заголовка таблицы истинности

(defrule print-header

; более низкий приоритет запрещает применение этого правила

; до окончания перебора всевозможных вариантов входных сигналов

(declare (salience -10) )

=>

; вывод списка источников

(do-for-all-instances ((?x SOURCE)) TRUE

(format t " %3s " (sym-cat ?x) ) )

; вывод разделительной линии

(printout t " | ")

; вывод списка индикаторов

(do-for-all-instances ( (?x LED)) TRUE

(format t " %3s " (sym-cat ?x) ) )

(format t "%n")

; вывод разделительной линии, отделяющей заголовок

(do-for-all-instances ((?x SOURCE)) TRUE

(printout t " ----- ") ) (printout t "-+-")

(do-for-all-instances ((?x LED)) TRUE

(printout t " ----- ") )

(format t "%n")

; запрос на печать таблицы истинности

(assert (print-results) )

)

;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

; Вывод таблицы истинности

(defrule print-result

; если заголовок уже напечатан

(print-results)

; еще остались не выведенные строки

?f <- (result $?input ?response)

; выбор наименьшей по порядку строки

(not (result $?input-2 ?response-2&:

(< (str-compare ?response-2 ?response) 0) ))

=>

; удаление выбранной строки

(retract ?f)

; вывод выбранной строки

(while (neq ?input (create$) ) do

(printout t " " (nth 1 ? input) "

(bind ?input (rest$ ? input) ))

(printout t " | ")

(bind ?response (str-explode ?response) )

(while (neq ?response (create$) ) do

(printout t " " (nth 1 ?response)

(bind ?response (rest$ ?response) ) )

(printout t crlf)

)

Создайте файл cios.CLP, содержащий текст переведенной выше программы. Как уже не раз упоминалось, среда CLIPS воспринимает только символы английского алфавита, поэтому комментарии, приведенные в листинге, необходимо опустить.