Find-function – Given some input/output pairs, find a general function that works with these.

find-function.scm

;;;; Find-function -- Given some input/output pairs, find a general function that works with these.

;;;; Copyright (C) 2016 Jeandre Kruger
;;;; All rights reserved.

;;;; Redistribution and use in source and binary forms, with or without modification,
;;;; are permitted provided that the following conditions are met:

;;;; 1. Redistributions of source code must retain the above copyright notice, this
;;;; list of conditions and the following disclaimer.

;;;; 2. Redistributions in binary form must reproduce the above copyright notice, this
;;;; list of conditions and the following disclaimer in the documentation and/or other
;;;; materials provided with the distribution.

;;;; 3. Neither the name of the copyright holder nor the names of its contributors may
;;;; be used to endorse or promote products derived from this software without specific
;;;; prior written permission.

;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT
;;;; SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;;;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
;;;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
;;;; EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;;; Ugly code warning :-/

;;;; Amb

(define (*fail*)
  (display-line "No more possible functions!")
  (*exit* #f))

(define-syntax amb
  (syntax-rules ()
    ((amb) (*fail*))
    ((amb exp1 exp2 ...)
     (let ((old-fail *fail*))
       ((call-with-current-continuation
         (lambda (cont)
           (set! *fail*
                 (lambda ()
                   (set! *fail* old-fail)
                   (cont (lambda () (amb exp2 ...)))))
           (lambda () exp1))))))))

(define (require test)
  (if (not test)
      (amb)))

;;;; User interface

(define *exit* #f)

(define (user-loop)
  (display "Enter some input/output pairs: ")
  (let ((ins-and-outs (read)))
    (display "Enter the maximum expression depth: ")
    (let ((max-depth (read)))
      (call-with-current-continuation
       (lambda (continuation)
         (set! *exit* continuation)
         (write-line (find-function ins-and-outs max-depth))
         (let loop ()
           (display "Show more? (y/n) ")
           (let ((show-more? (eq? (read) 'y)))
             (if show-more?
                 (begin (amb)
                        (loop)))))))
      (display-line "Goodbye."))))

;;;; Finding functions

(define (find-function ins-and-outs max-depth)
  (let* ((expression (generate-expression max-depth))
         (function (make-function expression))
         (procedure (expression->procedure expression)))
    (for-each
     (lambda (in-and-out)
       (display "Trying function: ")
       (write-line function)
       (require (= (procedure (car in-and-out)) (cadr in-and-out))))
     ins-and-outs)
    function))

(define (make-function expression)
  (make-combination '= (make-combination 'f 'x) expression))

;;;; Writing objects on lines

(define (display-line obj)
  (display obj)
  (newline))

(define (write-line obj)
  (write obj)
  (newline))

;;;; Generation of expressions

(define (generate-expression max-depth)
  (require (> max-depth 0))
  (amb (generate-number) (generate-variable) (generate-combination max-depth)))

(define (generate-number)
  (define (loop count)
    (require (<= count 5))
    (amb count (loop (+ count 1))))
  (loop -5))

(define (generate-variable) 'x)

(define (generate-combination max-depth)
  (let ((exp (make-combination (generate-operator)
                               (generate-expression (- max-depth 1))
                               (generate-expression (- max-depth 1)))))
    exp))

(define (generate-operator)
  (amb '+ '- '* '/))

(define (expression->procedure exp)
  ((eval `(lambda (require)
            (let ((/ (lambda (a b)
                       (require (not (= b 0)))
                       (/ a b))))
              (lambda (x) ,(expression->scheme exp))))
         (scheme-report-environment 5))
   require))

;;;; Expression data type

(define (make-combination operator . operands)
  (cons operator operands))

(define (operator exp) (car exp))
(define (operands exp) (cdr exp))

(define (expression->scheme exp) exp)

;;;; Run it

(user-loop)