file lib.rkt:
#lang typed/racket
(provide
distance
pt-to-string
(struct-out pt))
(struct pt ([x : Real] [y : Real]))
(: pt-to-string (-> pt String))
(define (pt-to-string p) (string-append "struct pt: x=" (number->string (pt-x p)) ", y=" (number->string (pt-y p)) "."))
(: distance (-> pt pt Real))
(define (distance p1 p2)
(sqrt (+ (sqr (- (pt-x p2) (pt-x p1)))
(sqr (- (pt-y p2) (pt-y p1))))))
file main.rkt:
#lang typed/racket
(require
; import struct pt only, include pt, pt-x and pt-y
(only-in "./lib.rkt" pt pt-x pt-y))
(define p (pt -1 1))
(displayln (pt-x p))
I want to import struct pt only ,which include pt pt-x and pt-y, but not import all other helper function such as distance and pt-to-string.
Is there anything corresponding to (provide (struct-out ...)) ?
Related
How can I use typed Racket for some functions in my codebase, but use (untyped) Racket for others? When I define a function in Racket but import it into a typed Racket context, it seems to be changing the behavior of the function (functions described below).
As it is now, the files do typecheck, but don't pass my tests in p11typedtest.rkt -- however, my files do successfully pass my tests if I either (A) switch p11typed.rkt to regular Racket or (B) copy the pack function into p11typed.rkt and provide its type annotation.
;; p09.rkt
#lang racket
(provide pack)
;; packs consecutive duplicates within a list into sublists
(define (pack lst)
(for/foldr ([acc '()]) ([x lst])
(match acc
[(cons (cons y ys) zs) #:when (equal? x y)
(list* (list* x y ys) zs)]
[_ (list* (list x) acc)]
)))
;; p11typed.rkt
#lang typed/racket
(provide encode-runlen-mod)
;; (require (only-in (file "p09.rkt") pack))
(require/typed (only-in (file "p09.rkt") pack)
[pack (All (A) (-> (Listof A) (Listof (Listof A))))]
)
(define-type (Runof a) (List Index a))
(define-type (RunListof a) (Listof (U a (Runof a))))
;; encodes a list as a list of runs
(: encode-runlen-mod (All (A) (-> (Listof A) (RunListof A))))
(define (encode-runlen-mod lst)
;; uncomment to print the result of pack
;; (displayln (pack lst))
(for/list ([dups (pack lst)])
(match (length dups)
[1 (car dups)]
[n (list n (car dups))]
)))
; (: pack (All (A) (-> (Listof A) (Listof (Listof A)))))
; (define (pack lst)
; (for/foldr ([acc '()]) ([x lst])
; (match acc
; [(cons (cons y ys) zs) #:when (equal? x y)
; (list* (list* x y ys) zs)]
; [_ (list* (list x) acc)]
; )))
;; p11typedtest.rkt
#lang racket
(require (only-in (file "p11typed.rkt") encode-runlen-mod))
(define (test-output namespace expr v)
(let* ([val (eval expr namespace)]
[fail (not (equal? val v))])
(begin
(display (if fail "FAIL" "ok "))
(display " '(=? ")
(print expr)
(display " ")
(print v)
(display ")'")
(if fail
(begin
(display ", got ")
(print val)
(displayln " instead")
)
(displayln "")
)
(void))
))
(define-namespace-anchor a)
(define ns (namespace-anchor->namespace a))
(test-output ns '(encode-runlen-mod '(1 2 3 4)) '(1 2 3 4))
(test-output ns '(encode-runlen-mod '(1 1 1)) '((3 1)))
(test-output ns '(encode-runlen-mod '(1 2 2 3 4)) '(1 (2 2) 3 4))
(test-output ns '(encode-runlen-mod '(1 2 3 4 4 4)) '(1 2 3 (3 4)))
(test-output ns '(encode-runlen-mod '(1 2 3 (3 4))) '(1 2 3 (3 4)))
(test-output ns '(encode-runlen-mod '(A A A A B C C A A D E E))
'((4 A) B (2 C) (2 A) D (2 E)))
)
I want to create own implementation of such interface with following procedures :
(define (cons a b)...)
(define (pair? p) ... )
(define (car p) ...)
(define (cdr p) ...)
(define null ... )
(define (null? p) ... )
Pair and other functions has to be represented as returned procedures.
I started with:
(define (cons a b)
(lambda (m) (m a b)))
(define (car p)
(p (lambda (x y) x)))
(define (cdr p)
(p (lambda (x y) y)))
And I'm stuck with:
(define (pair? p) ... )
(define null ... )
(define (null? p) ... )
I am trying to write a Scheme macro that loops over the prime numbers. Here is a simple version of the macro:
(define-syntax do-primes
(syntax-rules ()
((do-primes (p lo hi) (binding ...) (test res ...) exp ...)
(do ((p (next-prime (- lo 1)) (next-prime p)) binding ...)
((or test (< hi p)) res ...) exp ...))
((do-primes (p lo) (binding ...) (test res ...) exp ...)
(do ((p (next-prime (- lo 1)) (next-prime p)) binding ...)
(test res ...) exp ...))
((do-primes (p) (binding ...) (test res ...) exp ...)
(do ((p 2 (next-prime p)) binding ...) (test res ...) exp ...))))
The do-primes macro expands to a do with three possible syntaxes: if the first argument to do-primes is (p lo hi) then the do loops over the primes from lo to hi unless iteration is stopped early by the termination clause, if the first argument to do-primes is (p lo) then the do loops over the primes starting from lo and continuing until the termination clause stops the iteration, and if the first argument to do-primes is (p) then the do loops over the primes starting from 2 and continuing until the termination clause stops the iteration. Here are some sample uses of the do-primes macro:
; these lines display the primes less than 25
(do-primes (p 2 25) () (#f) (display p) (newline))
(do-primes (p 2) () ((< 25 p)) (display p) (newline))
(do-primes (p) () ((< 25 p)) (display p) (newline))
; these lines return a list of the primes less than 25
(do-primes (p 2 25) ((ps (list) (cons p ps))) (#f (reverse ps)))
(do-primes (p 2) ((ps (list) (cons p ps))) ((< 25 p) (reverse ps)))
(do-primes (p) ((ps (list) (cons p ps))) ((< 25 p) (reverse ps)))
; these lines return the sum of the primes less than 25
(do-primes (p 2 25) ((s 0 (+ s p))) (#f s))
(do-primes (p 2) ((s 0 (+ s p))) ((< 25 p) s))
(do-primes (p) ((s 0 (+ s p))) ((< 25 p) s))
What I want to do is write a version of the do-primes macro that uses a local version of the next-prime function; I want to do that because I can make the next-prime function run faster than my general-purpose next-prime function because I know the environment in which it will be called. I tried to write the macro like this:
(define-syntax do-primes
(let ()
(define (prime? n)
(if (< n 2) #f
(let loop ((f 2))
(if (< n (* f f)) #t
(if (zero? (modulo n f)) #f
(loop (+ f 1)))))))
(define (next-prime n)
(let loop ((n (+ n 1)))
(if (prime? n) n (loop (+ n 1)))))
(lambda (x) (syntax-case x ()
((do-primes (p lo hi) (binding ...) (test res ...) exp ...)
(syntax
(do ((p (next-prime (- lo 1)) (next-prime p)) binding ...)
((or test (< hi p)) res ...) exp ...)))
((do-primes (p lo) (binding ...) (test res ...) exp ...)
(syntax
(do ((p (next-prime (- lo 1)) (next-prime p)) binding ...)
(test res ...) exp ...)))
((do-primes (p) (binding ...) (test res ...) exp ...)
(syntax
(do ((p 2 (next-prime p)) binding ...) (test res ...) exp ...))))))))
(Ignore the prime? and next-prime functions, which are there only for illustration. The real version of the do-primes macro will use a segmented sieve for small primes and switch to a Baillie-Wagstaff pseudoprime test for larger primes.) But that doesn't work; I get an error message telling me that that I am trying "to reference out-of-phase identifier next-prime." I understand the problem. But my macrology wizardry is insufficient to solve it.
Can someone show me how to write the do-primes macro?
EDIT: Here is the final macro:
(define-syntax do-primes (syntax-rules () ; syntax for iterating over primes
; (do-primes (p lo hi) ((var init next) ...) (pred? result ...) expr ...)
; Macro do-primes provides syntax for iterating over primes. It expands to
; a do-loop with variable p bound in the same scope as the rest of the (var
; init next) variables, as if it were defined as (do ((p (primes lo hi) (cdr
; p)) (var init next) ...) (pred result ...) expr ...). Variables lo and hi
; are inclusive; for instance, given (p 2 11), p will take on the values 2,
; 3, 5, 7 and 11. If hi is omitted the iteration continues until stopped by
; pred?. If lo is also omitted iteration starts from 2. Some examples:
; three ways to display the primes less than 25
; (do-primes (p 2 25) () (#f) (display p) (newline))
; (do-primes (p 2) () ((< 25 p)) (display p) (newline))
; (do-primes (p) () ((< 25 p)) (display p) (newline))
; three ways to return a list of the primes less than 25
; (do-primes (p 2 25) ((ps (list) (cons p ps))) (#f (reverse ps)))
; (do-primes (p 2) ((ps (list) (cons p ps))) ((< 25 p) (reverse ps)))
; (do-primes (p) ((ps (list) (cons p ps))) ((< 25 p) (reverse ps)))
; three ways to return the sum of the primes less than 25
; (do-primes (p 2 25) ((s 0 (+ s p))) (#f s))
; (do-primes (p 2) ((s 0 (+ s p))) ((< 25 p) s))
; (do-primes (p) ((s 0 (+ s p))) ((< 25 p) s))
; functions to count primes and return the nth prime (from P[1] = 2)
; (define (prime-pi n) (do-primes (p) ((k 0 (+ k 1))) ((< n p) k)))
; (define (nth-prime n) (do-primes (p) ((n n (- n 1))) ((= n 1) p)))
; The algorithm used to generate primes is a segmented Sieve of Eratosthenes
; up to 2^32. For larger primes, a segmented sieve runs over the sieving
; primes up to 2^16 to produce prime candidates, then a Baillie-Wagstaff
; pseudoprimality test is performed to confirm the number is prime.
; If functions primes, expm, jacobi, strong-pseudoprime?, lucas, selfridge
; and lucas-pseudoprime? exist in the outer environment, they can be removed
; from the macro.
((do-primes (p lo hi) (binding ...) (test result ...) expr ...)
(do-primes (p lo) (binding ...) ((or test (< hi p)) result ...) expr ...))
((do-primes (pp low) (binding ...) (test result ...) expr ...)
(let* ((limit (expt 2 16)) (delta 50000) (limit2 (* limit limit))
(sieve (make-vector delta #t)) (ps #f) (qs #f) (bottom 0) (pos 0))
(define (primes n) ; sieve of eratosthenes
(let ((sieve (make-vector n #t)))
(let loop ((p 2) (ps (list)))
(cond ((= n p) (reverse ps))
((vector-ref sieve p)
(do ((i (* p p) (+ i p))) ((<= n i))
(vector-set! sieve i #f))
(loop (+ p 1) (cons p ps)))
(else (loop (+ p 1) ps))))))
(define (expm b e m) ; modular exponentiation
(let loop ((b b) (e e) (x 1))
(if (zero? e) x
(loop (modulo (* b b) m) (quotient e 2)
(if (odd? e) (modulo (* b x) m) x)))))
(define (jacobi a m) ; jacobi symbol
(let loop1 ((a (modulo a m)) (m m) (t 1))
(if (zero? a) (if (= m 1) t 0)
(let ((z (if (member (modulo m 8) (list 3 5)) -1 1)))
(let loop2 ((a a) (t t))
(if (even? a) (loop2 (/ a 2) (* t z))
(loop1 (modulo m a) a
(if (and (= (modulo a 4) 3)
(= (modulo m 4) 3))
(- t) t))))))))
(define (strong-pseudoprime? n a) ; strong pseudoprime base a
(let loop ((r 0) (s (- n 1)))
(if (even? s) (loop (+ r 1) (/ s 2))
(if (= (expm a s n) 1) #t
(let loop ((r r) (s s))
(cond ((zero? r) #f)
((= (expm a s n) (- n 1)) #t)
(else (loop (- r 1) (* s 2)))))))))
(define (lucas p q m n) ; lucas sequences u[n] and v[n] and q^n (mod m)
(define (even e o) (if (even? n) e o))
(define (mod n) (if (zero? m) n (modulo n m)))
(let ((d (- (* p p) (* 4 q))))
(let loop ((un 1) (vn p) (qn q) (n (quotient n 2))
(u (even 0 1)) (v (even 2 p)) (k (even 1 q)))
(if (zero? n) (values u v k)
(let ((u2 (mod (* un vn))) (v2 (mod (- (* vn vn) (* 2 qn))))
(q2 (mod (* qn qn))) (n2 (quotient n 2)))
(if (even? n) (loop u2 v2 q2 n2 u v k)
(let* ((uu (+ (* u v2) (* u2 v)))
(vv (+ (* v v2) (* d u u2)))
(uu (if (and (positive? m) (odd? uu)) (+ uu m) uu))
(vv (if (and (positive? m) (odd? vv)) (+ vv m) vv))
(uu (mod (/ uu 2))) (vv (mod (/ vv 2))))
(loop u2 v2 q2 n2 uu vv (* k q2)))))))))
(define (selfridge n) ; initialize lucas sequence
(let loop ((d-abs 5) (sign 1))
(let ((d (* d-abs sign)))
(cond ((< 1 (gcd d n)) (values d 0 0))
((= (jacobi d n) -1) (values d 1 (/ (- 1 d) 4)))
(else (loop (+ d-abs 2) (- sign)))))))
(define (lucas-pseudoprime? n) ; standard lucas pseudoprime
(call-with-values
(lambda () (selfridge n))
(lambda (d p q)
(if (zero? p) (= n d)
(call-with-values
(lambda () (lucas p q n (+ n 1)))
(lambda (u v qkd) (zero? u)))))))
(define (init lo) ; initialize sieve, return first prime
(set! bottom (if (< lo 3) 2 (if (odd? lo) (- lo 1) lo)))
(set! ps (cdr (primes limit))) (set! pos 0)
(set! qs (map (lambda (p) (modulo (/ (+ bottom p 1) -2) p)) ps))
(do ((p ps (cdr p)) (q qs (cdr q))) ((null? p))
(do ((i (+ (car p) (car q)) (+ i (car p)))) ((<= delta i))
(vector-set! sieve i #f)))
(if (< lo 3) 2 (next)))
(define (advance) ; advance to next segment
(set! bottom (+ bottom delta delta)) (set! pos 0)
(do ((i 0 (+ i 1))) ((= i delta)) (vector-set! sieve i #t))
(set! qs (map (lambda (p q) (modulo (- q delta) p)) ps qs))
(do ((p ps (cdr p)) (q qs (cdr q))) ((null? p))
(do ((i (car q) (+ i (car p)))) ((<= delta i))
(vector-set! sieve i #f))))
(define (next) ; next prime after current prime
(when (= pos delta) (advance))
(let ((p (+ bottom pos pos 1)))
(if (and (vector-ref sieve pos) (or (< p limit2)
(and (strong-pseudoprime? p 2) (lucas-pseudoprime? p))))
(begin (set! pos (+ pos 1)) p)
(begin (set! pos (+ pos 1)) (next)))))
(do ((pp (init low) (next)) binding ...) (test result ...) expr ...)))
((do-primes (p) (binding ...) (test result ...) expr ...)
(do-primes (p 2) (binding ...) (test result ...) expr ...))))
To get correct phasing, your next-prime needs to defined within the macro output. Here's one way to go about it (tested with Racket):
(define-syntax do-primes
(syntax-rules ()
((do-primes (p lo hi) (binding ...) (test res ...) exp ...)
(do-primes (p lo) (binding ...) ((or test (< hi p)) res ...) exp ...))
((do-primes (p lo) (binding ...) (test res ...) exp ...)
(let ()
(define (prime? n)
...)
(define (next-prime n)
...)
(do ((p (next-prime (- lo 1)) (next-prime p)) binding ...)
(test res ...)
exp ...)))
((do-primes (p) (binding ...) (test res ...) exp ...)
(do-primes (p 2) (binding ...) (test res ...) exp ...))))
This way, this defines the prime? and next-prime in the most local scope possible, while not having tons of duplicate code in your macro definition (since the 1- and 3-argument forms are simply rewritten to use the 2-argument form).
I'm trying to implement a Division function with clisp Lambda Calc. style
I read from this site that lambda expression of a division is:
Y (λgqab. LT a b (PAIR q a) (g (SUCC q) (SUB a b) b)) 0
These are TRUE and FALSE
(defvar TRUE #'(lambda(x)#'(lambda(y)x)))
(defvar FALSE #'(lambda(x)#'(lambda(y)y)))
These are conversion functions between Int and Church numbers
(defun church2int(numchurch)
(funcall (funcall numchurch #'(lambda (x) (+ x 1))) 0)
)
(defun int2church(n)
(cond
((= n 0) #'(lambda(f) #'(lambda(x)x)))
(t #'(lambda(f) #'(lambda(x) (funcall f
(funcall(funcall(int2church (- n 1))f)x))))))
)
This is my IF-THEN-ELSE Implementation
(defvar IF-THEN-ELSE
#'(lambda(c)
#'(lambda(x)
#'(lambda(y)
#'(lambda(acc1)
#'(lambda (acc2)
(funcall (funcall (funcall (funcall c x) y) acc1) acc2))))))
)
And this is my div implementation
(defvar division
#'(lambda (g)
#'(lambda (q)
#'(lambda (a)
#'(lambda (b)
(funcall (funcall (funcall (funcall (funcall IF-THEN-ELSE LT) a) b)
(funcall (funcall PAIR q)a))
(funcall (funcall g (funcall succ q)) (funcall (funcall sub a)b))
)))))
)
PAIR, SUCC and SUB functions work fine. I set my church numbers up like this
(set six (int2church 6))
(set two (int2church 2))
Then I do:
(setq D (funcall (funcall division six) two))
And I've got:
#<FUNCTION :LAMBDA (A)
#'(LAMBDA (B)
(FUNCALL (FUNCALL (FUNCALL (FUNCALL (FUNCALL IF-THEN-ELSE LT) A) B) (FUNCALL (FUNCALL PAR Q) A))
(FUNCALL (FUNCALL G (FUNCALL SUCC Q)) (FUNCALL (FUNCALL SUB A) B))))>
For what I understand, this function return a Church Pair. If I try to get the first element
with a function FRST (FRST works ok) like this:
(funcall frst D)
I've got
#<FUNCTION :LAMBDA (B)
(FUNCALL (FUNCALL (FUNCALL (FUNCALL (FUNCALL IF-THEN-ELSE LT) A) B) (FUNCALL (FUNCALL PAR Q) A))
(FUNCALL (FUNCALL G (FUNCALL SUCC Q)) (FUNCALL (FUNCALL SUB A) B)))>
If I try to get the int value with Church2int (Church2int works OK) like this:
(church2int (funcall frst D))
I've got
*** - +:
#<FUNCTION :LAMBDA (N)
#'(LAMBDA (F)
#'(LAMBDA (X)
(FUNCALL (FUNCALL (FUNCALL N #'(LAMBDA (G) #'(LAMBDA (H) (FUNCALL H (FUNCALL G F))))) #'(LAMBDA (U) X)) (LAMBDA (U) U))))>
is not a number
Where I expect to get 3
I think the problem is in DIVISION function, after the IF-THEN-ELSE, I tried to change it a little bit (I thought it was a nested parenthesis problem) but I got lots of errors.
Any help would be appreciated
Thanks
There are several problems with your definition.
DIVISION does not use the Y combinator, but the original definition does.
This is important, because the DIVISION function expects a copy of itself in the g
parameter.
However, even if you added the Y invocation, your code would still not work
but go into an infinite loop instead. That's because Common Lisp, like most of today's languages, is a call-by-value language. All arguments are evaluated before a function is called. This means that you cannot define conditional functions as elegantly as the traditional lambda calculus semantics would allow.
Here's one way of doing church number division in Common Lisp. I've taken the liberty of introducing some syntax to make this a bit more readable.
;;;; -*- coding: utf-8 -*-
;;;; --- preamble, define lambda calculus language
(cl:in-package #:cl-user)
(defpackage #:lambda-calc
;; note: not using common-lisp package
(:use)
(:export #:λ #:call #:define))
;; (lambda-calc:λ (x y) body)
;; ==> (cl:lambda (x) (cl:lambda (y) body))
(defmacro lambda-calc:λ ((arg &rest more-args) body-expr)
(labels ((rec (args)
(if (null args)
body-expr
`(lambda (,(car args))
(declare (ignorable ,(car args)))
,(rec (cdr args))))))
(rec (cons arg more-args))))
;; (lambda-calc:call f a b)
;; ==> (cl:funcall (cl:funcall f a) b)
(defmacro lambda-calc:call (func &rest args)
(labels ((rec (args)
(if (null args)
func
`(funcall ,(rec (cdr args)) ,(car args)))))
(rec (reverse args))))
;; Defines top-level lexical variables
(defmacro lambda-calc:define (name value)
(let ((vname (gensym (princ-to-string name))))
`(progn
(defparameter ,vname nil)
(define-symbol-macro ,name ,vname)
(setf ,name
(flet ((,vname () ,value))
(,vname))))))
;; Syntax: {f a b}
;; ==> (lambda-calc:call f a b)
;; ==> (cl:funcall (cl:funcall f a) b)
(eval-when (:compile-toplevel :load-toplevel :execute)
(set-macro-character #\{
(lambda (stream char)
(declare (ignore char))
`(lambda-calc:call
,#(read-delimited-list #\} stream t))))
(set-macro-character #\} (get-macro-character #\))))
;;;; --- end of preamble, fun starts here
(in-package #:lambda-calc)
;; booleans
(define TRUE
(λ (x y) x))
(define FALSE
(λ (x y) y))
(define NOT
(λ (bool) {bool FALSE TRUE}))
;; numbers
(define ZERO
(λ (f x) x))
(define SUCC
(λ (n f x) {f {n f x}}))
(define PLUS
(λ (m n) {m SUCC n}))
(define PRED
(λ (n f x)
{n (λ (g h) {h {g f}})
(λ (u) x)
(λ (u) u)}))
(define SUB
(λ (m n) {n PRED m}))
(define ISZERO
(λ (n) {n (λ (x) FALSE) TRUE}))
(define <=
(λ (m n) {ISZERO {SUB m n}}))
(define <
(λ (m n) {NOT {<= n m}}))
(define ONE {SUCC ZERO})
(define TWO {SUCC ONE})
(define THREE {SUCC TWO})
(define FOUR {SUCC THREE})
(define FIVE {SUCC FOUR})
(define SIX {SUCC FIVE})
(define SEVEN {SUCC SIX})
(define EIGHT {SUCC SEVEN})
(define NINE {SUCC EIGHT})
(define TEN {SUCC NINE})
;; combinators
(define Y
(λ (f)
{(λ (rec arg) {f {rec rec} arg})
(λ (rec arg) {f {rec rec} arg})}))
(define IF
(λ (condition if-true if-false)
{{condition if-true if-false} condition}))
;; pairs
(define PAIR
(λ (x y select) {select x y}))
(define FIRST
(λ (pair) {pair TRUE}))
(define SECOND
(λ (pair) {pair FALSE}))
;; conversion from/to lisp integers
(cl:defun int-to-church (number)
(cl:if (cl:zerop number)
zero
{succ (int-to-church (cl:1- number))}))
(cl:defun church-to-int (church-number)
{church-number #'cl:1+ 0})
;; what we're all here for
(define DIVISION
{Y (λ (recurse q a b)
{IF {< a b}
(λ (c) {PAIR q a})
(λ (c) {recurse {SUCC q} {SUB a b} b})})
ZERO})
If you put this into a file, you can do:
[1]> (load "lambdacalc.lisp")
;; Loading file lambdacalc.lisp ...
;; Loaded file lambdacalc.lisp
T
[2]> (in-package :lambda-calc)
#<PACKAGE LAMBDA-CALC>
LAMBDA-CALC[3]> (church-to-int {FIRST {DIVISION TEN FIVE}})
2
LAMBDA-CALC[4]> (church-to-int {SECOND {DIVISION TEN FIVE}})
0
LAMBDA-CALC[5]> (church-to-int {FIRST {DIVISION TEN FOUR}})
2
LAMBDA-CALC[6]> (church-to-int {SECOND {DIVISION TEN FOUR}})
2
I have found the code from this lesson online (http://groups.csail.mit.edu/mac/ftpdir/6.001-fall91/ps4/matcher-from-lecture.scm), and I am having a heck of a time trying to debug it. The code looks pretty comparable to what Sussman has written:
;;; Scheme code from the Pattern Matcher lecture
;; Pattern Matching and Simplification
(define (match pattern expression dictionary)
(cond ((eq? dictionary 'failed) 'failed)
((atom? pattern)
(if (atom? expression)
(if (eq? pattern expression)
dictionary
'failed)
'failed))
((arbitrary-constant? pattern)
(if (constant? expression)
(extend-dictionary pattern expression dictionary)
'failed))
((arbitrary-variable? pattern)
(if (variable? expression)
(extend-dictionary pattern expression dictionary)
'failed))
((arbitrary-expression? pattern)
(extend-dictionary pattern expression dictionary))
((atom? expression) 'failed)
(else
(match (cdr pattern)
(cdr expression)
(match (car pattern)
(car expression)
dictionary)))))
(define (instantiate skeleton dictionary)
(cond ((atom? skeleton) skeleton)
((skeleton-evaluation? skeleton)
(evaluate (evaluation-expression skeleton)
dictionary))
(else (cons (instantiate (car skeleton) dictionary)
(instantiate (cdr skeleton) dictionary)))))
(define (simplifier the-rules)
(define (simplify-exp exp)
(try-rules (if (compound? exp)
(simplify-parts exp)
exp)))
(define (simplify-parts exp)
(if (null? exp)
'()
(cons (simplify-exp (car exp))
(simplify-parts (cdr exp)))))
(define (try-rules exp)
(define (scan rules)
(if (null? rules)
exp
(let ((dictionary (match (pattern (car rules))
exp
(make-empty-dictionary))))
(if (eq? dictionary 'failed)
(scan (cdr rules))
(simplify-exp (instantiate (skeleton (car rules))
dictionary))))))
(scan the-rules))
simplify-exp)
;; Dictionaries
(define (make-empty-dictionary) '())
(define (extend-dictionary pat dat dictionary)
(let ((vname (variable-name pat)))
(let ((v (assq vname dictionary)))
(cond ((null? v)
(cons (list vname dat) dictionary))
((eq? (cadr v) dat) dictionary)
(else 'failed)))))
(define (lookup var dictionary)
(let ((v (assq var dictionary)))
(if (null? v)
var
(cadr v))))
;; Expressions
(define (compound? exp) (pair? exp))
(define (constant? exp) (number? exp))
(define (variable? exp) (atom? exp))
;; Rules
(define (pattern rule) (car rule))
(define (skeleton rule) (cadr rule))
;; Patterns
(define (arbitrary-constant? pattern)
(if (pair? pattern) (eq? (car pattern) '?c) false))
(define (arbitrary-expression? pattern)
(if (pair? pattern) (eq? (car pattern) '? ) false))
(define (arbitrary-variable? pattern)
(if (pair? pattern) (eq? (car pattern) '?v) false))
(define (variable-name pattern) (cadr pattern))
;; Skeletons & Evaluations
(define (skeleton-evaluation? skeleton)
(if (pair? skeleton) (eq? (car skeleton) ':) false))
(define (evaluation-expression evaluation) (cadr evaluation))
;; Evaluate (dangerous magic)
(define (evaluate form dictionary)
(if (atom? form)
(lookup form dictionary)
(apply (eval (lookup (car form) dictionary)
user-initial-environment)
(mapcar (lambda (v) (lookup v dictionary))
(cdr form)))))
;;
;; A couple sample rule databases...
;;
;; Algebraic simplification
(define algebra-rules
'(
( ((? op) (?c c1) (?c c2)) (: (op c1 c2)) )
( ((? op) (? e ) (?c c )) ((: op) (: c) (: e)) )
( (+ 0 (? e)) (: e) )
( (* 1 (? e)) (: e) )
( (* 0 (? e)) 0 )
( (* (?c c1) (* (?c c2) (? e ))) (* (: (* c1 c2)) (: e)) )
( (* (? e1) (* (?c c ) (? e2))) (* (: c ) (* (: e1) (: e2))) )
( (* (* (? e1) (? e2)) (? e3)) (* (: e1) (* (: e2) (: e3))) )
( (+ (?c c1) (+ (?c c2) (? e ))) (+ (: (+ c1 c2)) (: e)) )
( (+ (? e1) (+ (?c c ) (? e2))) (+ (: c ) (+ (: e1) (: e2))) )
( (+ (+ (? e1) (? e2)) (? e3)) (+ (: e1) (+ (: e2) (: e3))) )
( (+ (* (?c c1) (? e)) (* (?c c2) (? e))) (* (: (+ c1 c2)) (: e)) )
( (* (? e1) (+ (? e2) (? e3))) (+ (* (: e1) (: e2))
(* (: e1) (: e3))) )
))
(define algsimp (simplifier algebra-rules))
;; Symbolic Differentiation
(define deriv-rules
'(
( (dd (?c c) (? v)) 0 )
( (dd (?v v) (? v)) 1 )
( (dd (?v u) (? v)) 0 )
( (dd (+ (? x1) (? x2)) (? v)) (+ (dd (: x1) (: v))
(dd (: x2) (: v))) )
( (dd (* (? x1) (? x2)) (? v)) (+ (* (: x1) (dd (: x2) (: v)))
(* (dd (: x1) (: v)) (: x2))) )
( (dd (** (? x) (?c n)) (? v)) (* (* (: n) (+ (: x) (: (- n 1))))
(dd (: x) (: v))) )
))
(define dsimp (simplifier deriv-rules))
(define scheme-rules
'(( (square (?c n)) (: (* n n)) )
( (fact 0) 1 )
( (fact (?c n)) (* (: n) (fact (: (- n 1)))) )
( (fib 0) 0 )
( (fib 1) 1 )
( (fib (?c n)) (+ (fib (: (- n 1)))
(fib (: (- n 2)))) )
( ((? op) (?c e1) (?c e2)) (: (op e1 e2)) ) ))
(define scheme-evaluator (simplifier scheme-rules))
I'm running it in DrRacket with the R5RS, and the first problem I ran into was that atom? was an undefined identifier. So, I found that I could add the following:
(define (atom? x) ; atom? is not in a pair or null (empty)
(and (not (pair? x))
(not (null? x))))
I then tried to figure out how to actually run this beast, so I watched the video again and saw him use the following:
(dsimp '(dd (+ x y) x))
As stated by Sussman, I should get back (+ 1 0). Instead, using R5RS I seem to be breaking in the extend-dictionary procedure at the line:
((eq? (cadr v) dat) dictionary)
The specific error it's returning is: mcdr: expects argument of type mutable-pair; given #f
When using neil/sicp I'm breaking in the evaluate procedure at the line:
(apply (eval (lookup (car form) dictionary)
user-initial-environment)
The specific error it's returning is: unbound identifier in module in: user-initial-environment
So, with all of that being said, I'd appreciate some help, or the a good nudge in the right direction. Thanks!
Your code is from 1991. Since R5RS came out in 1998, the code must be written for R4RS (or older).
One of the differences between R4RS and later Schemes is that the empty list was interpreted as false in the R4RS and as true in R5RS.
Example:
(if '() 1 2)
gives 1 in R5RS but 2 in R4RS.
Procedures such as assq could therefore return '() instead of false.
This is why you need to change the definition of extend-directory to:
(define (extend-dictionary pat dat dictionary)
(let ((vname (variable-name pat)))
(let ((v (assq vname dictionary)))
(cond ((not v)
(cons (list vname dat) dictionary))
((eq? (cadr v) dat) dictionary)
(else 'failed)))))
Also back in those days map was called mapcar. Simply replace mapcar with map.
The error you saw in DrRacket was:
mcdr: expects argument of type <mutable-pair>; given '()
This means that cdr got an empty list. Since an empty list has
no cdr this gives an error message. Now DrRacket writes mcdr
instead of cdr, but ignore that for now.
Best advice: Go through one function at a time and test it with
a few expressions in the REPL. This is easier than figuring
everything out at once.
Finally begin your program with:
(define user-initial-environment (scheme-report-environment 5))
Another change from R4RS (or MIT Scheme in 1991?).
Addendum:
This code http://pages.cs.brandeis.edu/~mairson/Courses/cs21b/sym-diff.scm almost runs.
Prefix it in DrRacket with:
#lang r5rs
(define false #f)
(define user-initial-environment (scheme-report-environment 5))
(define mapcar map)
And in extend-directory change the (null? v) to (not v).
That at least works for simple expressions.
Here is the code that works for me with mit-scheme (Release 9.1.1).
You also may use this code. It runs on Racket.
For running "eval" without errors, the following needed to be added
(define ns (make-base-namespace))
(apply (eval '+ ns) '(1 2 3))