4.3.2 · Реализация вычислителя amb

Вычислитель amb и продолжение неудачи

Вычислитель передает продолжения успеха и неудачи. Amb хранит оставшиеся варианты в пути неудачи, а require вызывает его при нарушении ограничения.

Вопрос для размышления

Как вычислитель может превратить неудачу из фатальной ошибки в запрос на возобновление работы с предыдущей точки выбора?

Вычисление выражений guest с явными продолжениями успеха и неудачи
Представление составных процедур guest с лексическими окружениями
Передача альтернативных продолжений через вычисление оператора и операндов
Реализация amb путем проверки каждого варианта с путем неудачи к остальным
Реализация require путем вызова текущей альтернативы, когда ее предикат ложен
Сбор каждого конечного решения или остановка на явном пределе решений
Сохранение в поле зрения пропущенного отката присваиваний и политики справедливости

Процедура ambeval принимает expression, environment, succeed и fail. Детерминированное выражение вызывает succeed со своим значением и с продолжением неудачи, которое следует использовать, если последующая работа отклонит это значение. Форма amb вычисляет свой первый вариант и заменяет неудачу процедурой, проверяющей оставшиеся варианты. Вычисление операндов передает эти продолжения слева направо, поэтому неудача внутри тела процедуры может вернуться к более раннему недетерминированному аргументу.

Форма require вычисляет свой предикат в той же системе продолжений. Истинный предикат завершается успехом со значением ok, а ложный предикат вызывает следующую альтернативу предиката, которая в итоге возвращается к самому последнему выбору amb. Процедура all-values повторно вызывает следующую альтернативу, предоставляемую каждым успехом. Первый запуск исчерпывает выбранный конечный поиск и сообщает complete. Второй запуск намеренно останавливается после четырех решений и сообщает truncated. Учебный вычислитель охватывает упорядоченные варианты amb, форму require, применение процедур и передачу продолжений успеха или неудачи.

Код SICP7,667 из 1,048,576 байт UTF-8

(begin
  (define (tagged-list? expression tag)
    (and (pair? expression) (eq? (car expression) tag)))
  (define (self-evaluating? expression)
    (or (number? expression)
        (string? expression)
        (boolean? expression)))
  (define (quoted? expression) (tagged-list? expression 'quote))
  (define (if? expression) (tagged-list? expression 'if))
  (define (lambda? expression) (tagged-list? expression 'lambda))
  (define (begin? expression) (tagged-list? expression 'begin))
  (define (amb? expression) (tagged-list? expression 'amb))
  (define (require? expression) (tagged-list? expression 'require))

  (define (text-of-quotation expression) (cadr expression))
  (define (if-predicate expression) (cadr expression))
  (define (if-consequent expression) (caddr expression))
  (define (if-alternative expression) (cadddr expression))
  (define (lambda-parameters expression) (cadr expression))
  (define (lambda-body expression) (cddr expression))
  (define (begin-actions expression) (cdr expression))
  (define (amb-choices expression) (cdr expression))
  (define (require-predicate expression) (cadr expression))
  (define (operator expression) (car expression))
  (define (operands expression) (cdr expression))

  (define (pair-bindings variables values)
    (cond ((and (null? variables) (null? values)) '())
          ((null? variables) (error "too many arguments"))
          ((null? values) (error "too few arguments"))
          (else
           (cons (cons (car variables) (car values))
                 (pair-bindings (cdr variables) (cdr values))))))
  (define (extend-environment variables values environment)
    (append (pair-bindings variables values) environment))
  (define (lookup-variable-value variable environment)
    (let ((binding (assoc variable environment)))
      (if binding
          (cdr binding)
          (error "unbound guest variable" variable))))

  (define (make-procedure parameters body environment)
    (list 'compound parameters body environment))
  (define (compound-procedure? procedure)
    (tagged-list? procedure 'compound))
  (define (procedure-parameters procedure) (cadr procedure))
  (define (procedure-body procedure) (caddr procedure))
  (define (procedure-environment procedure) (cadddr procedure))

  (define (eval-sequence expressions environment succeed fail)
    (cond ((null? expressions) (succeed 'ok fail))
          ((null? (cdr expressions))
           (ambeval (car expressions) environment succeed fail))
          (else
           (ambeval
             (car expressions)
             environment
             (lambda (ignored next-alternative)
               (eval-sequence
                 (cdr expressions)
                 environment
                 succeed
                 next-alternative))
             fail))))

  (define (get-arguments expressions environment succeed fail)
    (if (null? expressions)
        (succeed '() fail)
        (ambeval
          (car expressions)
          environment
          (lambda (argument next-argument)
            (get-arguments
              (cdr expressions)
              environment
              (lambda (remaining next-remaining)
                (succeed (cons argument remaining) next-remaining))
              next-argument))
          fail)))

  (define (apply-procedure procedure arguments succeed fail)
    (cond ((procedure? procedure)
           (succeed (apply procedure arguments) fail))
          ((compound-procedure? procedure)
           (eval-sequence
             (procedure-body procedure)
             (extend-environment
               (procedure-parameters procedure)
               arguments
               (procedure-environment procedure))
             succeed
             fail))
          (else
           (error "not a guest procedure" procedure))))

  (define (eval-if expression environment succeed fail)
    (ambeval
      (if-predicate expression)
      environment
      (lambda (predicate-value next-predicate)
        (ambeval
          (if predicate-value
              (if-consequent expression)
              (if-alternative expression))
          environment
          succeed
          next-predicate))
      fail))

  (define (eval-require expression environment succeed fail)
    (ambeval
      (require-predicate expression)
      environment
      (lambda (predicate-value next-predicate)
        (if predicate-value
            (succeed 'ok next-predicate)
            (next-predicate)))
      fail))

  (define (eval-amb choices environment succeed fail)
    (define (try-next remaining)
      (if (null? remaining)
          (fail)
          (ambeval
            (car remaining)
            environment
            succeed
            (lambda () (try-next (cdr remaining))))))
    (try-next choices))

  (define (eval-application expression environment succeed fail)
    (ambeval
      (operator expression)
      environment
      (lambda (procedure next-operator)
        (get-arguments
          (operands expression)
          environment
          (lambda (arguments next-arguments)
            (apply-procedure
              procedure
              arguments
              succeed
              next-arguments))
          next-operator))
      fail))

  (define (ambeval expression environment succeed fail)
    (cond ((self-evaluating? expression)
           (succeed expression fail))
          ((symbol? expression)
           (succeed
             (lookup-variable-value expression environment)
             fail))
          ((quoted? expression)
           (succeed (text-of-quotation expression) fail))
          ((if? expression)
           (eval-if expression environment succeed fail))
          ((lambda? expression)
           (succeed
             (make-procedure
               (lambda-parameters expression)
               (lambda-body expression)
               environment)
             fail))
          ((begin? expression)
           (eval-sequence
             (begin-actions expression)
             environment
             succeed
             fail))
          ((amb? expression)
           (eval-amb
             (amb-choices expression)
             environment
             succeed
             fail))
          ((require? expression)
           (eval-require expression environment succeed fail))
          ((pair? expression)
           (eval-application expression environment succeed fail))
          (else
           (error "unknown guest expression" expression))))

  (define primitive-environment
    (list (cons '+ +) (cons '- -) (cons '* *) (cons '/ /)
          (cons '= =) (cons '< <) (cons '> >)
          (cons '<= <=) (cons '>= >=)
          (cons 'list list) (cons 'cons cons)
          (cons 'car car) (cons 'cdr cdr)
          (cons 'null? null?) (cons 'pair? pair?)
          (cons 'not not) (cons 'abs abs)))

  (define (all-values expression solution-limit)
    (if (= solution-limit 0)
        (list 'truncated '())
        (let ((answers '())
              (count 0))
          (ambeval
            expression
            primitive-environment
            (lambda (value next-alternative)
              (set! answers (cons value answers))
              (set! count (+ count 1))
              (if (= count solution-limit)
                  (list 'truncated (reverse answers))
                  (next-alternative)))
            (lambda ()
              (list 'complete (reverse answers)))))))
  (define pair-program
    '((lambda (left right)
        (begin
          (require (< left right))
          (require (= (+ left right) 5))
          (list left right)))
      (amb 1 2 3 4)
      (amb 1 2 3 4)))
  (all-values pair-program 20)
)

(begin
  (define (tagged-list? expression tag)
    (and (pair? expression) (eq? (car expression) tag)))
  (define (self-evaluating? expression)
    (or (number? expression)
        (string? expression)
        (boolean? expression)))
  (define (quoted? expression) (tagged-list? expression 'quote))
  (define (if? expression) (tagged-list? expression 'if))
  (define (lambda? expression) (tagged-list? expression 'lambda))
  (define (begin? expression) (tagged-list? expression 'begin))
  (define (amb? expression) (tagged-list? expression 'amb))
  (define (require? expression) (tagged-list? expression 'require))

(define (text-of-quotation expression) (cadr expression))
  (define (if-predicate expression) (cadr expression))
  (define (if-consequent expression) (caddr expression))
  (define (if-alternative expression) (cadddr expression))
  (define (lambda-parameters expression) (cadr expression))
  (define (lambda-body expression) (cddr expression))
  (define (begin-actions expression) (cdr expression))
  (define (amb-choices expression) (cdr expression))
  (define (require-predicate expression) (cadr expression))
  (define (operator expression) (car expression))
  (define (operands expression) (cdr expression))

(define (pair-bindings variables values)
    (cond ((and (null? variables) (null? values)) '())
          ((null? variables) (error "too many arguments"))
          ((null? values) (error "too few arguments"))
          (else
           (cons (cons (car variables) (car values))
                 (pair-bindings (cdr variables) (cdr values))))))
  (define (extend-environment variables values environment)
    (append (pair-bindings variables values) environment))
  (define (lookup-variable-value variable environment)
    (let ((binding (assoc variable environment)))
      (if binding
          (cdr binding)
          (error "unbound guest variable" variable))))

(define (make-procedure parameters body environment)
    (list 'compound parameters body environment))
  (define (compound-procedure? procedure)
    (tagged-list? procedure 'compound))
  (define (procedure-parameters procedure) (cadr procedure))
  (define (procedure-body procedure) (caddr procedure))
  (define (procedure-environment procedure) (cadddr procedure))

(define (eval-sequence expressions environment succeed fail)
    (cond ((null? expressions) (succeed 'ok fail))
          ((null? (cdr expressions))
           (ambeval (car expressions) environment succeed fail))
          (else
           (ambeval
             (car expressions)
             environment
             (lambda (ignored next-alternative)
               (eval-sequence
                 (cdr expressions)
                 environment
                 succeed
                 next-alternative))
             fail))))

(define (get-arguments expressions environment succeed fail)
    (if (null? expressions)
        (succeed '() fail)
        (ambeval
          (car expressions)
          environment
          (lambda (argument next-argument)
            (get-arguments
              (cdr expressions)
              environment
              (lambda (remaining next-remaining)
                (succeed (cons argument remaining) next-remaining))
              next-argument))
          fail)))

(define (apply-procedure procedure arguments succeed fail)
    (cond ((procedure? procedure)
           (succeed (apply procedure arguments) fail))
          ((compound-procedure? procedure)
           (eval-sequence
             (procedure-body procedure)
             (extend-environment
               (procedure-parameters procedure)
               arguments
               (procedure-environment procedure))
             succeed
             fail))
          (else
           (error "not a guest procedure" procedure))))

(define (eval-if expression environment succeed fail)
    (ambeval
      (if-predicate expression)
      environment
      (lambda (predicate-value next-predicate)
        (ambeval
          (if predicate-value
              (if-consequent expression)
              (if-alternative expression))
          environment
          succeed
          next-predicate))
      fail))

(define (eval-require expression environment succeed fail)
    (ambeval
      (require-predicate expression)
      environment
      (lambda (predicate-value next-predicate)
        (if predicate-value
            (succeed 'ok next-predicate)
            (next-predicate)))
      fail))

(define (eval-amb choices environment succeed fail)
    (define (try-next remaining)
      (if (null? remaining)
          (fail)
          (ambeval
            (car remaining)
            environment
            succeed
            (lambda () (try-next (cdr remaining))))))
    (try-next choices))

(define (eval-application expression environment succeed fail)
    (ambeval
      (operator expression)
      environment
      (lambda (procedure next-operator)
        (get-arguments
          (operands expression)
          environment
          (lambda (arguments next-arguments)
            (apply-procedure
              procedure
              arguments
              succeed
              next-arguments))
          next-operator))
      fail))

(define (ambeval expression environment succeed fail)
    (cond ((self-evaluating? expression)
           (succeed expression fail))
          ((symbol? expression)
           (succeed
             (lookup-variable-value expression environment)
             fail))
          ((quoted? expression)
           (succeed (text-of-quotation expression) fail))
          ((if? expression)
           (eval-if expression environment succeed fail))
          ((lambda? expression)
           (succeed
             (make-procedure
               (lambda-parameters expression)
               (lambda-body expression)
               environment)
             fail))
          ((begin? expression)
           (eval-sequence
             (begin-actions expression)
             environment
             succeed
             fail))
          ((amb? expression)
           (eval-amb
             (amb-choices expression)
             environment
             succeed
             fail))
          ((require? expression)
           (eval-require expression environment succeed fail))
          ((pair? expression)
           (eval-application expression environment succeed fail))
          (else
           (error "unknown guest expression" expression))))

(define primitive-environment
    (list (cons '+ +) (cons '- -) (cons '* *) (cons '/ /)
          (cons '= =) (cons '< <) (cons '> >)
          (cons '<= <=) (cons '>= >=)
          (cons 'list list) (cons 'cons cons)
          (cons 'car car) (cons 'cdr cdr)
          (cons 'null? null?) (cons 'pair? pair?)
          (cons 'not not) (cons 'abs abs)))

(define (all-values expression solution-limit)
    (if (= solution-limit 0)
        (list 'truncated '())
        (let ((answers '())
              (count 0))
          (ambeval
            expression
            primitive-environment
            (lambda (value next-alternative)
              (set! answers (cons value answers))
              (set! count (+ count 1))
              (if (= count solution-limit)
                  (list 'truncated (reverse answers))
                  (next-alternative)))
            (lambda ()
              (list 'complete (reverse answers)))))))
  (define pair-program
    '((lambda (left right)
        (begin
          (require (< left right))
          (require (= (+ left right) 5))
          (list left right)))
      (amb 1 2 3 4)
      (amb 1 2 3 4)))
  (all-values pair-program 20)
)

Примеры

Результат—

Вывод: —
Значение: —
Диагностика: —

Трасса выполнения0 / 0 событий

Ожидаемый результат

Поиск пар возвращает (complete ((1 4) (2 3))). Поиск троек с ограничением возвращает (truncated ((1 2 3) (1 2 4) (1 2 5) (1 3 4))).

На что обратить внимание в трассе

Проследите за тем, как каждый выбор amb устанавливает продолжение неудачи для оставшихся вариантов. Затем проследите за get-arguments, когда отклоненный require в теле поочередно возобновляет следующий третий аргумент, следующий второй аргумент или следующий первый аргумент. Поиск останавливается, когда исчерпывает свои варианты или достигает установленного предела решений.

Попробуйте сами

Измените программу и сравните результат.

Измените программу для пар так, чтобы переменные left и right выбирались от 1 до 6, потребуйте через require равенства их произведения 12 и соберите все решения, в которых left меньше. Спрогнозируйте порядок решений перед запуском.

Показать подсказку

Порядок amb слева направо проверяет все варианты right для left 1 перед переходом к left 2. Только упорядоченные пары множителей проходят обе формы require.

Завершить этот урок

В этой главе пройдено 0 из 23 урока0%