Регистрация | Войти
Lisp — программируемый язык программирования
RSS
как работает функция
klichko - 26.10.2014 11:09, Сообщений - 3


Добрый день, товарисчи.

есть код на scheme, который решает задачу:

1.Напишите функцию, (f F1), которая выдает логическую формулу F2, получающуюся из логической формулы F1 внесением всех операторов отрицания внутрь конъюнкций и дизъюнкций.

пример входных данных:

(f '(~ (& (~ (v b (& c d))) (v c (~ d)))))
'(v (v b (& c d)) (& (~ c) d))

нужна помощь, как переписать этот код на homelisp?

а конкретней, вот эту функцию normal-args?


;;;; Применение правил де Моргана

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Определим элементы исчисления высказываний L

;;;; Множество булевых чисел Boolean = {#t, #f}

;;;; Множество формул F

;;;; Множество простых высказываний P - состоит из букв латинского алфавита,
;;;; исключая "v". Каждому p из P соответствует некоторое значение из Boolean

;;;; Множество логических связок S = {~, v, &},
;;;; каждому элементу которого соответсвует единственный
;;;; элемент из множества S1 логических функций Lisp. S1 = {not, or, and}
;;;; ~: F     -> F (not)
;;;; v: F x F -> F (or)
;;;; &: F x F -> F (and)

;;;; Множество формул F определим по индукции
;;;; 1) если p - простое высказывание, то p - формула
;;;; 2) если p, q - формулы, то (~ p), (& p q), (v p q) - тоже формулы
;;;; Формулы также являются высказываниями
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Законы де Моргана
;;;; (~ (v p q)) <-> ((~p) & (~q))
;;;; (~ (& p q)) <-> ((~p) v (~q))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Функция S? - является ли символ связкой
;;; S?: Symbol -> Boolean
(define (S? sym)
  (cond ((eq? sym 'v)
         #t
)

        ((eq? sym '&)
         #t
)

        ((eq? sym '~)
         #t
)

        (else
         #f
)
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Функция arity - арность связки
;;; arity: S -> Number
(define (arity s)
  (if (eq? s '~)
      1
      2
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Функция normal-args-count? - проверяет, соответсвует ли число аргументов
;;; формулы арности связки
;;; normal-args-count: F -> Boolean
(define (normal-args-count? p)
  (= (length (cdr p))
     (arity (car p))
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Функция normal-args? - проверяет число и типы аргументов связки в формуле
;;; normal-args?: F -> Boolean
(define (normal-args? p)
  (if (normal-args-count? p)
      (let iter ((args (cdr p))
                 (cnt (arity (car p)))
)

        (cond ((= cnt 0)
               #t
)

              ((and (not (list? (car args)))
                    (S? (car args))
)

               #f
)

              (else
               (iter (cdr args) (- cnt 1))
)
)
)

      #f
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Функция get-f - возвращает для 'v '& и наоборот
;;; get-f: S -> S
(define (get-f s)
  (cond ((eq? s 'v)
         '&
)

        ((eq? s '&)
         'v
)
)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Функция f - применение законов де Моргана
;;; f: F -> F
(define (f F1)
  ;; Функция process - преобразование формул по законам де Моргана
 ;; process: P -> P
 (define (process F1)
    (let ((s (car F1)))
      (if (S? s)
          (cond ((not (normal-args? F1))
                 (error "process -- некорректная формула:" F1)
)

                ((eq? s '~)
                 (f (cadr F1))
)

                (else
                 (list (get-f s)
                       (f (list '~ (cadr F1)))
                       (f (list '~ (caddr F1)))
)
)
)

          (error "process -- переданный символ не является связкой:" s)
)
)
)

  
  (cond ((null? F1)
         '()
)

        ((list? F1)
         (let ((s (car F1)))
           (if (S? s)
               (cond ((not (normal-args? F1))
                      (error "f -- некорректная формула:" F1)
)

                     ((eq? s '~)
                      (if (list? (cadr F1))
                          (process (cadr F1))
                          F1
)
)

                     (else
                      (list s (f (cadr F1)) (f (caddr F1)))
)
)

               (error "f -- переданный символ не является связкой:" s)
)
)
)

        (else
         F1
)
)
)

[#]
До сессии вроде бы ещё далеко...
archimag - 26.10.2014 11:32
[#] Ответ на комментарий от archimag 26.10.2014 11:32
а по делу есть что сказать?
klichko - 26.10.2014 17:35
[#]
всем спасибо, сам разобрался:)

(defun S (sym)
        (cond ((eq sym 'v) t)
        ((eq sym '&) t)
        ((eq sym '~) t)
        (t nil)
        
)

)


(defun arity (s)
          (if (eq s '~) 1 2)
)



(defun normal-args-count (p)
          (= (length (cdr p))(arity (car p))
        
)

)


(defun normal-args (p)
          (if (normal-args-count p)
                 (let ((args (cdr p)) (cnt (arity (car p))))
                                (labels ((iter (args cnt)
                                        (cond
                                                ((= cnt 0) t)
                                              ((and (not (list (car args))) (S (car args))) nil)
                                              (t (iter (cdr args)(- cnt 1)))
                                        
)
)

                                        
                                
)
(iter (cdr p) (arity (car p)))
)

                
)

        
)

)


(defun get-f (s)
          (cond ((eq s 'v) '&)
                 ((eq s '&) 'v)
        
)

)


(defun f (F1)
          (defun process (F1)
                (let ((ca (car F1)))         
                        (if (S ca)
                                (cond ((not (normal-args F1)) ("pr -- некорректная формула:"))
                                ((eq ca '~) (f (cadr F1)))
                                (t (list (get-f ca) (f (list '~ (cadr F1)))
                                       (f (list '~ (caddr F1)))
)
)

                                
)

                          ("proc -- переданный символ не является связкой:")
                        
)

                
)

        
)

             (cond         ((null F1) '())
                 ((not (atom F1)) (let ((ca (car F1)))
                          (if (S ca)
                               (cond ((not (normal-args F1)) "f -- некорректная формула:")
                                     ((eq ca '~) (if (not (atom (cadr F1))) (process (cadr F1)) F1))
                                     (t (list ca (f (cadr F1)) (f (caddr F1))))
                                
)

                       ("f -- переданный символ не является связкой:")
)
)
)

                 (t F1)
)

 
        
)
klichko - 26.10.2014 18:13
@2009-2013 lisper.ru