Конвертировать код из Lisp в SCHEME - PullRequest
Новая
       50

Конвертировать код из Lisp в SCHEME

0 голосов
/ 06 июня 2018

У меня есть рабочая программа на Common Lisp, и я пытаюсь заставить ее работать и в Scheme, но она не работает.Код предназначен для поиска в глубине в структуре, называемой vecinos
Lisp Code: 

(setq vecinos '((a . (b c d))
            (b . (a h))
            (c . (a g))
            (d . (g))
            (g . (c d k))
            (h . (b))
            (g . (k)) ) )

( cdr (assoc 'a vecinos))
( cdr (assoc 'b vecinos))

(defmacro get.value (X vecinos) `(cdr (assoc, X, vecinos))) 

(defun extiende (trayectoria)
  (mapcar #'(lambda (nuevo-nodo) (append trayectoria (list nuevo-nodo)))
    (remove-if #'(lambda (vecino) (member vecino trayectoria))
               (get.value (car (last trayectoria)) vecinos))))

(defun primero-en-profundidad (inicial final)
  (primero-en-profundidad-aux inicial final (list (list inicial))))

(defun primero-en-profundidad-aux (inicial final abierta)
  (cond ((eq inicial final)
     (print (list inicial)))
    ((member (list inicial final) (extiende (list inicial)))
     (print (list inicial final)))
    ((member final (first abierta))
     (print (first abierta)))
    (t (primero-en-profundidad-aux inicial final (append (extiende (first abierta)) (rest abierta))))
    ))

(primero-en-profundidad 'a 'a)
(primero-en-profundidad 'a 'k)

Код схемы: 

#lang scheme

(define vecinos '((a . (b c d)) 
            (b . (a h))
            (c . (a g))
            (d . (g))
            (g . (c d k))
            (h . (b))
            (g . (k)) ) )

(define (get-value X vecinos) 
   (cond ((eq? (assoc X vecinos) #f) null)
      (#t (cdr (assq X vecinos)) ) ))

И я думаю, что этоэто то, что неправильно, потому что в схеме нет remove-if , которое используется в определении extiende 

(define (extiende trayectoria)
  (map car (lambda (nuevo-nodo) (append trayectoria (list nuevo-nodo)))
  (remove-if (lambda (vecino) (member vecino trayectoria)) 
         (get-value (car (last trayectoria)) vecinos))))

(define (primero-en-profundidad inicial final)
  (primero-en-profundidad-aux inicial final (list (list inicial))))

(define (primero-en-profundidad-aux inicial final abierta)
  (cond ((eqv? inicial final)
     (print (list inicial)))
    ((member (list inicial final) (extiende (list inicial)))
     (print (list inicial final)))
    ((member final (first abierta))
     (print (first abierta)))
    (#t (primero-en-profundidad-aux inicial final (append (extiende (first abierta)) (rest abierta))))
))

Результат должен быть 

(primero-en-profundidad '(a) '(a))

(A) 

(primero-en-profundidad '(a) '(k))

(ACGK)

Ответы [ 2 ]

0 голосов
/ 07 июня 2018

Прежде всего, большое спасибо @coredump за существенное улучшение кода в CL!

Я перенес его в Racket. 

#lang racket

(define *graph*
  '((a . (b c d))
    (b . (a h))
    (c . (a g))
    (d . (g))
    (g . (c d k))
    (h . (b))
    (g . (k))))

(define (adjacent-nodes node graph)
    (cdr (assoc node graph)))

(define (unvisited-neighbours node path graph)
    (filter-not (lambda (neighbour)
                  (member neighbour path))
                (adjacent-nodes node graph)))

(define (extend-path path graph)
    (map (lambda (new-node)
           (cons new-node path))
         (unvisited-neighbours (first path) path graph)))

;; use a local auxiliary function with CL labels => Racket letrec
(define (depth-first-search initial final graph)
    (letrec ((dfs (lambda (paths)
                    (cond ((not paths) '())
                          ((eq? initial final) (list initial))
                          ((member final (first paths))
                           (reverse (first paths)))
                          (else (dfs (append (extend-path (first paths) graph)
                                          (rest paths))))))))
      (dfs (list (list initial)))))

Небольшой тест: 

(depth-first-search 'a 'a *graph*)
;; '(a)

(depth-first-search 'a 'k *graph*)
;; '(a c g k)

Некоторые правила для переноса из CL в Racket (просто небольшое подмножество правил, но этого было достаточно для этого примера): 

;; CL function definitions          (defun fn-name (args*) <body>)
;; Racket function definitions      (define (fn-name args*) <body>)
;;                                  ;; expands to the old notation:
;;                                  (define fn-name (lambda (args*) <body>)
;;                                  which shows that fn-name is just 
;;                                    a variable name which bears in     
;;                                    itself a lambda-expression
;;                                    a named lambda so to say
;;                                    this shows the nature of functions 
;;                                    in racket/scheme:
;;                                    just another variable (remember:    
;;                                    racket/scheme is a Lisp1, 
;;                                    so variables and functions share 
;;                                    the same namespace!)
;;                                  while in CL, which is a Lisp2, 
;;                                    variables have a different namespace 
;;                                    than functions.
;;                                  that is why in CL you need `#'` 
;;                                  attached in front of function names 
;;                                    when passed to higher order functions 
;;                                    as arguments telling: 
;;                                    lookup in function namespace!
;;                                  consequently, there is no 
;;                                    `#'` notation in racket/scheme.


;; CL                               (cond ((cond*) <body>)
;;                                        (t <body>))
;; Racket                           (cond ((cond*) <body>)
;;                                        (else <body>))

;; truth                            t nil
;;                                  #t #f in Racket, '() is NOT false!

;; CL                               '() = () = 'nil = nil
;; Racket                           '() [ () is illegal empty expression ] 
;;                                      !=   '#t = #t

;; CL                               mapcar
;; Racket                           map

;; CL                               remove-if-not remove-if
;; Racket                           filter        filter-not

;; CL                               labels
;; Racket                           letrec   ((fn-name (lambda (args*) 
;;                                                        <body>))

;; CL predicates - some have `p` at end (for `predicate`), some not 
;;                 and historically old predicates have no `p` at end.   
;;           eq equal atom null
;;           = > < etc. 
;;           string= etc char=
;;           evenp oddp
;; Racket predicates much more regularly end with `?`            
;;           eq? equal? atom? null?    
;;           = > < etc.  ;; well, but for numerical ones no `?` at end
;;           string=? etc. char=?
;;           even? odd?
0 голосов
/ 06 июня 2018

Распространенные проблемы с Лиспом 

(setq vecinos '((a . (b c d)) ...)

Используйте *earmuffs*, то есть звездочки вокруг глобальных (специальных) переменных.Также не используйте setq с неопределенными переменными.См. Разница между `set`,` setq` и `setf` в Common Lisp? . 

(defun primero-en-profundidad-aux (inicial final abierta)
  (cond ((eq inicial final)
         (print (list inicial)))
        ;; dead code
        ;; ((member (list inicial final) (extiende (list inicial)))
        ;;  (print (list inicial final)))
        ((member final (first abierta))
         (print (first abierta)))
        (t (primero-en-profundidad-aux inicial final (append (extiende (first abierta)) (rest abierta))))))

Часть, помеченная как мертвый код , мертва, потому чтоmember по умолчанию проверяет с помощью eql, который проверяет "то же несоставное значение".Если разные списки содержат одинаковые элементы, возвращается ноль.Кроме того, насколько я знаю, код на самом деле не нужен, потому что он включен в последний тест.

Для справки приведу переписанную реализацию CL.Основное отличие состоит в том, что каждый путь используется в качестве стека: исходная реализация продолжала добавляться в конец списка, что требует большого количества обходов и выделения большого количества ресурсов (текущая реализация все еще далека от оптимальной с точки зрения ресурсовиспользование, но оно близко к оригиналу).В конце путь меняется на обратный, только когда это необходимо. 

(defpackage :vecinos (:use :cl))
(in-package :vecinos)

(defparameter *graph*
  '((a . (b c d))
    (b . (a h))
    (c . (a g))
    (d . (g))
    (g . (c d k))
    (h . (b))
    (g . (k))))

;; might as well be a function
(defmacro adjacent-nodes (node graph)
  `(cdr (assoc ,node ,graph))) 

(defun unvisited-neighbours (node path graph)
  (remove-if (lambda (neighbour)
               (member neighbour path))
             (adjacent-nodes node graph)))

(defun extend-path (path graph)
  (mapcar (lambda (new-node)
            (cons new-node path))
          (unvisited-neighbours (first path) path graph)))

;; use a local auxiliary function (with labels)
(defun depth-first-search (initial final graph)
  (labels ((dfs (paths)
             (cond
               ((not paths) nil)
               ((eq initial final) (list initial))
               ((member final (first paths))
                (reverse (first paths)))
               (t (dfs (append (extend-path (first paths) graph)
                               (rest paths)))))))
    (dfs (list (list initial)))))

(depth-first-search 'a 'k *graph*)

Подсказки по ракетке

Ракетка определяет функцию filter, которую поддерживает элементы, удовлетворяющие предикату.Вам нужно использовать дополнение (not?) вашего предиката.

...